| [613] | 1 | DIKCU2 ;SFISC/MKO-ARRAY COMPARE, TEXT MANIPULATION ;2:40 PM 28 Jan 1998
|
|---|
| 2 | ;;22.0;VA FileMan;;Mar 30, 1999
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;===============================
|
|---|
| 6 | ; $$GCMP(ArrayName1,ArrayName2)
|
|---|
| 7 | ;===============================
|
|---|
| 8 | ;Compare the contents of two arrays
|
|---|
| 9 | ;In:
|
|---|
| 10 | ; DIKCU2A0 = Name of array 1
|
|---|
| 11 | ; DIKCU2B0 = Name of array 2
|
|---|
| 12 | ;Returns: 1 if equal, 0 if unequal
|
|---|
| 13 | ;
|
|---|
| 14 | GCMP(DIKCU2A0,DIKCU2B0) ;
|
|---|
| 15 | N DIKCU2A,DIKCU2B,DIKCU2DA,DIKCU2DB,DIKCU2E
|
|---|
| 16 | S DIKCU2A=$G(DIKCU2A0),DIKCU2B=$G(DIKCU2B0)
|
|---|
| 17 | Q:DIKCU2A=""!(DIKCU2B="") 0
|
|---|
| 18 | ;
|
|---|
| 19 | S DIKCU2DA=$D(@DIKCU2A),DIKCU2DB=$D(@DIKCU2B)
|
|---|
| 20 | Q:DIKCU2DA'=DIKCU2DB 0
|
|---|
| 21 | I DIKCU2DA=0,DIKCU2DB=0 Q 1
|
|---|
| 22 | I DIKCU2DA#2,DIKCU2DB#2,@DIKCU2A'=@DIKCU2B Q 0
|
|---|
| 23 | ;
|
|---|
| 24 | S DIKCU2E=1
|
|---|
| 25 | S DIKCU2A0=$$OREF^DILF(DIKCU2A0),DIKCU2B0=$$OREF^DILF(DIKCU2B0)
|
|---|
| 26 | F S DIKCU2A=$Q(@DIKCU2A),DIKCU2B=$Q(@DIKCU2B) D Q:'DIKCU2E!(DIKCU2A="")!(DIKCU2B="")
|
|---|
| 27 | . I DIKCU2A=""!($P(DIKCU2A,DIKCU2A0)]""),DIKCU2B=""!($P(DIKCU2B,DIKCU2B0)]"") Q
|
|---|
| 28 | . I DIKCU2A=""!(DIKCU2B="") S DIKCU2E=0 Q
|
|---|
| 29 | . I $P(DIKCU2A,DIKCU2A0,2,999)'=$P(DIKCU2B,DIKCU2B0,2,999) S DIKCU2E=0 Q
|
|---|
| 30 | . I @DIKCU2A'=@DIKCU2B S DIKCU2E=0 Q
|
|---|
| 31 | Q DIKCU2E
|
|---|
| 32 | ;
|
|---|
| 33 | ;==================================================
|
|---|
| 34 | ; XRINFO(Xref#,.UIR,.LDif,.MaxL,.RFile,.IRoot,.SS)
|
|---|
| 35 | ;==================================================
|
|---|
| 36 | ;Get info about an index
|
|---|
| 37 | ;In:
|
|---|
| 38 | ; XR = ien of entry in Index file
|
|---|
| 39 | ;Out:
|
|---|
| 40 | ; .UIR = Closed root of index w/ X(n)
|
|---|
| 41 | ; .LDIF = Level difference between file and root file
|
|---|
| 42 | ; .MAXL(ord#) = maximum length of subscript with this order #
|
|---|
| 43 | ; .IROOT = Closed root of index (up to name)
|
|---|
| 44 | ; .RFILE = Root file #
|
|---|
| 45 | ; .SS = # of field-type subscripts
|
|---|
| 46 | ; .SS(ss#) = file#^field#^maxLen
|
|---|
| 47 | ;Example: a whole file xref defined 3 levels down; the xref resides
|
|---|
| 48 | ; on the subfile 2 levels down.
|
|---|
| 49 | ; UIR = ^DIZ(1000,DA(3),10,DA(2),20,"WF",$E(X(1),1,30),X(2))
|
|---|
| 50 | ; RFILE = 1000.03
|
|---|
| 51 | ; IROOT = ^DIZ(1000,DA(3),10,DA(2),20,"WF")
|
|---|
| 52 | ;
|
|---|
| 53 | XRINFO(XR,UIR,LDIF,MAXL,RFILE,IROOT,SS) ;
|
|---|
| 54 | K UIR,LDIF,MAXL,SS
|
|---|
| 55 | Q:$D(^DD("IX",XR,0))[0
|
|---|
| 56 | N CRV,FIL,FILE,FLD,ML,NAME,ORD,TYPE,S
|
|---|
| 57 | ;
|
|---|
| 58 | S FILE=$P(^DD("IX",XR,0),U),NAME=$P(^(0),U,2),TYPE=$P(^(0),U,8),RFILE=$P(^(0),U,9)
|
|---|
| 59 | Q:NAME=""!'FILE!'RFILE
|
|---|
| 60 | ;
|
|---|
| 61 | I FILE'=RFILE D
|
|---|
| 62 | . S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE) Q:LDIF=""
|
|---|
| 63 | . S UIR=$$FROOTDA^DIKCU(FILE,LDIF_"O") Q:UIR=""
|
|---|
| 64 | E D
|
|---|
| 65 | . S LDIF=0
|
|---|
| 66 | . S UIR=$$FROOTDA^DIKCU(FILE,"O") Q:UIR=""
|
|---|
| 67 | Q:$G(UIR)=""
|
|---|
| 68 | S UIR=UIR_""""_NAME_"""",IROOT=UIR_")"
|
|---|
| 69 | ;
|
|---|
| 70 | S S=0 F S S=$O(^DD("IX",XR,11.1,"AC",S)) Q:'S S CRV=$O(^(S,0)) D:CRV
|
|---|
| 71 | . Q:$D(^DD("IX",XR,11.1,CRV,0))[0 S ORD=$P(^(0),U),FIL=$P(^(0),U,3),FLD=$P(^(0),U,4),ML=$P(^(0),U,5)
|
|---|
| 72 | . Q:'ORD
|
|---|
| 73 | . I ML S UIR=UIR_",$E(X("_ORD_"),1,"_ML_")",MAXL(ORD)=ML
|
|---|
| 74 | . E S UIR=UIR_",X("_ORD_")"
|
|---|
| 75 | . I FIL,FLD S SS=$G(SS)+1,SS(S)=FIL_U_FLD_$S(ML:U_ML,1:"")
|
|---|
| 76 | ;
|
|---|
| 77 | S UIR=UIR_")"
|
|---|
| 78 | Q
|
|---|
| 79 | ;
|
|---|
| 80 | ;===============================
|
|---|
| 81 | ; WRAP(.Text,Width,Width1,Code)
|
|---|
| 82 | ;===============================
|
|---|
| 83 | ;Wrap the lines in array T
|
|---|
| 84 | ;In:
|
|---|
| 85 | ; .T = array of text; 1st line can be in T or T(0)
|
|---|
| 86 | ; subsequent lines are in T(1),...,T(n)
|
|---|
| 87 | ; WID = maximum length of each line (default = IOM[or 80]-1)
|
|---|
| 88 | ; if < 0 : IOM-1+WID
|
|---|
| 89 | ; WID1 = maximum length of line 1 (optional)
|
|---|
| 90 | ; if "" : WID
|
|---|
| 91 | ; if < 0 : IOM-1+WID1
|
|---|
| 92 | ; COD = 1, if lines should NOT wrap on word boundaries
|
|---|
| 93 | ;
|
|---|
| 94 | WRAP(T,WID,WID1,COD) ;Wrap the lines in the T array
|
|---|
| 95 | Q:'$D(T)
|
|---|
| 96 | N E,J,P,T0,W
|
|---|
| 97 | ;
|
|---|
| 98 | S WID=$G(WID)\1
|
|---|
| 99 | S:WID<1 WID=$G(IOM,80)-1+WID
|
|---|
| 100 | S:WID<1 WID=79
|
|---|
| 101 | ;
|
|---|
| 102 | S W=$S($G(WID1):WID1\1,$G(WID1)=0:$G(IOM,80)-1,1:WID)
|
|---|
| 103 | S:W<1 W=$G(IOM,80)-1+W
|
|---|
| 104 | S:W<1 W=79
|
|---|
| 105 | ;
|
|---|
| 106 | I $D(T(0))[0 S T0=1,T(0)=T
|
|---|
| 107 | ;
|
|---|
| 108 | ;Wrap at word boundaries
|
|---|
| 109 | I '$G(COD) F J=0:1 Q:'$D(T(J)) D
|
|---|
| 110 | . S:J=1 W=WID
|
|---|
| 111 | . S:J T(J)=$$LD(T(J))
|
|---|
| 112 | . ;
|
|---|
| 113 | . ;Line must be split
|
|---|
| 114 | . I $L(T(J))>W D
|
|---|
| 115 | .. D DOWNT
|
|---|
| 116 | .. F P=$L(T(J)," "):-1:0 Q:$L($P(T(J)," ",1,P))'>W
|
|---|
| 117 | .. I 'P S T(J+1)=$E(T(J),W+1,999),T(J)=$E(T(J),1,W)
|
|---|
| 118 | .. E S T(J+1)=$$LD($P(T(J)," ",P+1,999)),T(J)=$$TR($P(T(J)," ",1,P))
|
|---|
| 119 | . ;
|
|---|
| 120 | . ;Or line must be joined with next
|
|---|
| 121 | . E I $L(T(J))<W D
|
|---|
| 122 | .. Q:'$D(T(J+1))
|
|---|
| 123 | .. I T(J)]"",T(J)'?.E1" " S T(J)=T(J)_" "
|
|---|
| 124 | .. S T(J+1)=$$LD(T(J+1))
|
|---|
| 125 | .. ;
|
|---|
| 126 | .. F P=1:1:$L(T(J+1)," ")+1 Q:$L(T(J))+$L($P(T(J+1)," ",1,P))>W
|
|---|
| 127 | .. S T(J)=$$TR(T(J)_$P(T(J+1)," ",1,P-1))
|
|---|
| 128 | .. S T(J+1)=$$LD($P(T(J+1)," ",P,999))
|
|---|
| 129 | .. I T(J+1)="" D UPT S J=J-1
|
|---|
| 130 | ;
|
|---|
| 131 | ;Or wrap to width
|
|---|
| 132 | E F J=0:1 Q:'$D(T(J)) D
|
|---|
| 133 | . S:J=1 W=WID
|
|---|
| 134 | . ;
|
|---|
| 135 | . ;Line must be split
|
|---|
| 136 | . I $L(T(J))>W D
|
|---|
| 137 | .. D DOWNT
|
|---|
| 138 | .. S T(J+1)=$E(T(J),W+1,999)
|
|---|
| 139 | .. S T(J)=$E(T(J),1,W)
|
|---|
| 140 | . ;
|
|---|
| 141 | . ;Or joined with next
|
|---|
| 142 | . E I $L(T(J))<W D
|
|---|
| 143 | .. Q:'$D(T(J+1))
|
|---|
| 144 | .. S E=W-$L(T(J))
|
|---|
| 145 | .. S T(J)=T(J)_$E(T(J+1),1,E)
|
|---|
| 146 | .. S T(J+1)=$E(T(J+1),E+1,999)
|
|---|
| 147 | .. I T(J+1)="" D UPT S J=J-1
|
|---|
| 148 | ;
|
|---|
| 149 | I $G(T0) S T=T(0) K T(0)
|
|---|
| 150 | Q
|
|---|
| 151 | ;
|
|---|
| 152 | DOWNT ;Push the T array from element J+1 down
|
|---|
| 153 | N K
|
|---|
| 154 | F K=$O(T(""),-1):-1:J+1 S T(K+1)=T(K)
|
|---|
| 155 | S T(J+1)=""
|
|---|
| 156 | Q
|
|---|
| 157 | ;
|
|---|
| 158 | UPT ;Pop the T array from element J+1 down
|
|---|
| 159 | N K
|
|---|
| 160 | F K=J+1:1:$O(T(""),-1)-1 S T(K)=T(K+1)
|
|---|
| 161 | K T($O(T(""),-1))
|
|---|
| 162 | Q
|
|---|
| 163 | ;
|
|---|
| 164 | TR(X) ;Strip trailing spaces
|
|---|
| 165 | Q:$G(X)="" X
|
|---|
| 166 | N I
|
|---|
| 167 | F I=$L(X):-1:0 Q:$E(X,I)'=" "
|
|---|
| 168 | Q $E(X,1,I)
|
|---|
| 169 | ;
|
|---|
| 170 | LD(X) ;Strip leading spaces
|
|---|
| 171 | Q:$G(X)="" X
|
|---|
| 172 | N I
|
|---|
| 173 | F I=1:1:$L(X)+1 Q:$E(X,I)'=" "
|
|---|
| 174 | Q $E(X,I,999)
|
|---|
| 175 | ;
|
|---|
| 176 | ERR(ERR,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;Build an error message
|
|---|
| 177 | N P,I,V
|
|---|
| 178 | F I="FILE","IENS","FIELD",1,2,3 S V=$G(@("DI"_I)) S:V]"" P(I)=V
|
|---|
| 179 | D BLD^DIALOG(ERR,.P,.P)
|
|---|
| 180 | Q
|
|---|
