- DIKCU2 ;SFISC/MKO-ARRAY COMPARE, TEXT MANIPULATION ;2:40 PM 28 Jan 1998
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;===============================
- ; $$GCMP(ArrayName1,ArrayName2)
- ;===============================
- ;Compare the contents of two arrays
- ;In:
- ; DIKCU2A0 = Name of array 1
- ; DIKCU2B0 = Name of array 2
- ;Returns: 1 if equal, 0 if unequal
- ;
- GCMP(DIKCU2A0,DIKCU2B0) ;
- N DIKCU2A,DIKCU2B,DIKCU2DA,DIKCU2DB,DIKCU2E
- S DIKCU2A=$G(DIKCU2A0),DIKCU2B=$G(DIKCU2B0)
- Q:DIKCU2A=""!(DIKCU2B="") 0
- ;
- S DIKCU2DA=$D(@DIKCU2A),DIKCU2DB=$D(@DIKCU2B)
- Q:DIKCU2DA'=DIKCU2DB 0
- I DIKCU2DA=0,DIKCU2DB=0 Q 1
- I DIKCU2DA#2,DIKCU2DB#2,@DIKCU2A'=@DIKCU2B Q 0
- ;
- S DIKCU2E=1
- S DIKCU2A0=$$OREF^DILF(DIKCU2A0),DIKCU2B0=$$OREF^DILF(DIKCU2B0)
- F S DIKCU2A=$Q(@DIKCU2A),DIKCU2B=$Q(@DIKCU2B) D Q:'DIKCU2E!(DIKCU2A="")!(DIKCU2B="")
- . I DIKCU2A=""!($P(DIKCU2A,DIKCU2A0)]""),DIKCU2B=""!($P(DIKCU2B,DIKCU2B0)]"") Q
- . I DIKCU2A=""!(DIKCU2B="") S DIKCU2E=0 Q
- . I $P(DIKCU2A,DIKCU2A0,2,999)'=$P(DIKCU2B,DIKCU2B0,2,999) S DIKCU2E=0 Q
- . I @DIKCU2A'=@DIKCU2B S DIKCU2E=0 Q
- Q DIKCU2E
- ;
- ;==================================================
- ; XRINFO(Xref#,.UIR,.LDif,.MaxL,.RFile,.IRoot,.SS)
- ;==================================================
- ;Get info about an index
- ;In:
- ; XR = ien of entry in Index file
- ;Out:
- ; .UIR = Closed root of index w/ X(n)
- ; .LDIF = Level difference between file and root file
- ; .MAXL(ord#) = maximum length of subscript with this order #
- ; .IROOT = Closed root of index (up to name)
- ; .RFILE = Root file #
- ; .SS = # of field-type subscripts
- ; .SS(ss#) = file#^field#^maxLen
- ;Example: a whole file xref defined 3 levels down; the xref resides
- ; on the subfile 2 levels down.
- ; UIR = ^DIZ(1000,DA(3),10,DA(2),20,"WF",$E(X(1),1,30),X(2))
- ; RFILE = 1000.03
- ; IROOT = ^DIZ(1000,DA(3),10,DA(2),20,"WF")
- ;
- XRINFO(XR,UIR,LDIF,MAXL,RFILE,IROOT,SS) ;
- K UIR,LDIF,MAXL,SS
- Q:$D(^DD("IX",XR,0))[0
- N CRV,FIL,FILE,FLD,ML,NAME,ORD,TYPE,S
- ;
- S FILE=$P(^DD("IX",XR,0),U),NAME=$P(^(0),U,2),TYPE=$P(^(0),U,8),RFILE=$P(^(0),U,9)
- Q:NAME=""!'FILE!'RFILE
- ;
- I FILE'=RFILE D
- . S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE) Q:LDIF=""
- . S UIR=$$FROOTDA^DIKCU(FILE,LDIF_"O") Q:UIR=""
- E D
- . S LDIF=0
- . S UIR=$$FROOTDA^DIKCU(FILE,"O") Q:UIR=""
- Q:$G(UIR)=""
- S UIR=UIR_""""_NAME_"""",IROOT=UIR_")"
- ;
- S S=0 F S S=$O(^DD("IX",XR,11.1,"AC",S)) Q:'S S CRV=$O(^(S,0)) D:CRV
- . 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)
- . Q:'ORD
- . I ML S UIR=UIR_",$E(X("_ORD_"),1,"_ML_")",MAXL(ORD)=ML
- . E S UIR=UIR_",X("_ORD_")"
- . I FIL,FLD S SS=$G(SS)+1,SS(S)=FIL_U_FLD_$S(ML:U_ML,1:"")
- ;
- S UIR=UIR_")"
- Q
- ;
- ;===============================
- ; WRAP(.Text,Width,Width1,Code)
- ;===============================
- ;Wrap the lines in array T
- ;In:
- ; .T = array of text; 1st line can be in T or T(0)
- ; subsequent lines are in T(1),...,T(n)
- ; WID = maximum length of each line (default = IOM[or 80]-1)
- ; if < 0 : IOM-1+WID
- ; WID1 = maximum length of line 1 (optional)
- ; if "" : WID
- ; if < 0 : IOM-1+WID1
- ; COD = 1, if lines should NOT wrap on word boundaries
- ;
- WRAP(T,WID,WID1,COD) ;Wrap the lines in the T array
- Q:'$D(T)
- N E,J,P,T0,W
- ;
- S WID=$G(WID)\1
- S:WID<1 WID=$G(IOM,80)-1+WID
- S:WID<1 WID=79
- ;
- S W=$S($G(WID1):WID1\1,$G(WID1)=0:$G(IOM,80)-1,1:WID)
- S:W<1 W=$G(IOM,80)-1+W
- S:W<1 W=79
- ;
- I $D(T(0))[0 S T0=1,T(0)=T
- ;
- ;Wrap at word boundaries
- I '$G(COD) F J=0:1 Q:'$D(T(J)) D
- . S:J=1 W=WID
- . S:J T(J)=$$LD(T(J))
- . ;
- . ;Line must be split
- . I $L(T(J))>W D
- .. D DOWNT
- .. F P=$L(T(J)," "):-1:0 Q:$L($P(T(J)," ",1,P))'>W
- .. I 'P S T(J+1)=$E(T(J),W+1,999),T(J)=$E(T(J),1,W)
- .. E S T(J+1)=$$LD($P(T(J)," ",P+1,999)),T(J)=$$TR($P(T(J)," ",1,P))
- . ;
- . ;Or line must be joined with next
- . E I $L(T(J))<W D
- .. Q:'$D(T(J+1))
- .. I T(J)]"",T(J)'?.E1" " S T(J)=T(J)_" "
- .. S T(J+1)=$$LD(T(J+1))
- .. ;
- .. F P=1:1:$L(T(J+1)," ")+1 Q:$L(T(J))+$L($P(T(J+1)," ",1,P))>W
- .. S T(J)=$$TR(T(J)_$P(T(J+1)," ",1,P-1))
- .. S T(J+1)=$$LD($P(T(J+1)," ",P,999))
- .. I T(J+1)="" D UPT S J=J-1
- ;
- ;Or wrap to width
- E F J=0:1 Q:'$D(T(J)) D
- . S:J=1 W=WID
- . ;
- . ;Line must be split
- . I $L(T(J))>W D
- .. D DOWNT
- .. S T(J+1)=$E(T(J),W+1,999)
- .. S T(J)=$E(T(J),1,W)
- . ;
- . ;Or joined with next
- . E I $L(T(J))<W D
- .. Q:'$D(T(J+1))
- .. S E=W-$L(T(J))
- .. S T(J)=T(J)_$E(T(J+1),1,E)
- .. S T(J+1)=$E(T(J+1),E+1,999)
- .. I T(J+1)="" D UPT S J=J-1
- ;
- I $G(T0) S T=T(0) K T(0)
- Q
- ;
- DOWNT ;Push the T array from element J+1 down
- N K
- F K=$O(T(""),-1):-1:J+1 S T(K+1)=T(K)
- S T(J+1)=""
- Q
- ;
- UPT ;Pop the T array from element J+1 down
- N K
- F K=J+1:1:$O(T(""),-1)-1 S T(K)=T(K+1)
- K T($O(T(""),-1))
- Q
- ;
- TR(X) ;Strip trailing spaces
- Q:$G(X)="" X
- N I
- F I=$L(X):-1:0 Q:$E(X,I)'=" "
- Q $E(X,1,I)
- ;
- LD(X) ;Strip leading spaces
- Q:$G(X)="" X
- N I
- F I=1:1:$L(X)+1 Q:$E(X,I)'=" "
- Q $E(X,I,999)
- ;
- ERR(ERR,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;Build an error message
- N P,I,V
- F I="FILE","IENS","FIELD",1,2,3 S V=$G(@("DI"_I)) S:V]"" P(I)=V
- D BLD^DIALOG(ERR,.P,.P)
- Q
- DIKCU2 ;SFISC/MKO-ARRAY COMPARE, TEXT MANIPULATION ;2:40 PM 28 Jan 1998
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;===============================
- +5 ; $$GCMP(ArrayName1,ArrayName2)
- +6 ;===============================
- +7 ;Compare the contents of two arrays
- +8 ;In:
- +9 ; DIKCU2A0 = Name of array 1
- +10 ; DIKCU2B0 = Name of array 2
- +11 ;Returns: 1 if equal, 0 if unequal
- +12 ;
- GCMP(DIKCU2A0,DIKCU2B0) ;
- +1 NEW DIKCU2A,DIKCU2B,DIKCU2DA,DIKCU2DB,DIKCU2E
- +2 SET DIKCU2A=$GET(DIKCU2A0)
- SET DIKCU2B=$GET(DIKCU2B0)
- +3 IF DIKCU2A=""!(DIKCU2B="")
- QUIT 0
- +4 ;
- +5 SET DIKCU2DA=$DATA(@DIKCU2A)
- SET DIKCU2DB=$DATA(@DIKCU2B)
- +6 IF DIKCU2DA'=DIKCU2DB
- QUIT 0
- +7 IF DIKCU2DA=0
- IF DIKCU2DB=0
- QUIT 1
- +8 IF DIKCU2DA#2
- IF DIKCU2DB#2
- IF @DIKCU2A'=@DIKCU2B
- QUIT 0
- +9 ;
- +10 SET DIKCU2E=1
- +11 SET DIKCU2A0=$$OREF^DILF(DIKCU2A0)
- SET DIKCU2B0=$$OREF^DILF(DIKCU2B0)
- +12 FOR
- SET DIKCU2A=$QUERY(@DIKCU2A)
- SET DIKCU2B=$QUERY(@DIKCU2B)
- Begin DoDot:1
- +13 IF DIKCU2A=""!($PIECE(DIKCU2A,DIKCU2A0)]"")
- IF DIKCU2B=""!($PIECE(DIKCU2B,DIKCU2B0)]"")
- QUIT
- +14 IF DIKCU2A=""!(DIKCU2B="")
- SET DIKCU2E=0
- QUIT
- +15 IF $PIECE(DIKCU2A,DIKCU2A0,2,999)'=$PIECE(DIKCU2B,DIKCU2B0,2,999)
- SET DIKCU2E=0
- QUIT
- +16 IF @DIKCU2A'=@DIKCU2B
- SET DIKCU2E=0
- QUIT
- End DoDot:1
- IF 'DIKCU2E!(DIKCU2A="")!(DIKCU2B="")
- QUIT
- +17 QUIT DIKCU2E
- +18 ;
- +19 ;==================================================
- +20 ; XRINFO(Xref#,.UIR,.LDif,.MaxL,.RFile,.IRoot,.SS)
- +21 ;==================================================
- +22 ;Get info about an index
- +23 ;In:
- +24 ; XR = ien of entry in Index file
- +25 ;Out:
- +26 ; .UIR = Closed root of index w/ X(n)
- +27 ; .LDIF = Level difference between file and root file
- +28 ; .MAXL(ord#) = maximum length of subscript with this order #
- +29 ; .IROOT = Closed root of index (up to name)
- +30 ; .RFILE = Root file #
- +31 ; .SS = # of field-type subscripts
- +32 ; .SS(ss#) = file#^field#^maxLen
- +33 ;Example: a whole file xref defined 3 levels down; the xref resides
- +34 ; on the subfile 2 levels down.
- +35 ; UIR = ^DIZ(1000,DA(3),10,DA(2),20,"WF",$E(X(1),1,30),X(2))
- +36 ; RFILE = 1000.03
- +37 ; IROOT = ^DIZ(1000,DA(3),10,DA(2),20,"WF")
- +38 ;
- XRINFO(XR,UIR,LDIF,MAXL,RFILE,IROOT,SS) ;
- +1 KILL UIR,LDIF,MAXL,SS
- +2 IF $DATA(^DD("IX",XR,0))[0
- QUIT
- +3 NEW CRV,FIL,FILE,FLD,ML,NAME,ORD,TYPE,S
- +4 ;
- +5 SET FILE=$PIECE(^DD("IX",XR,0),U)
- SET NAME=$PIECE(^(0),U,2)
- SET TYPE=$PIECE(^(0),U,8)
- SET RFILE=$PIECE(^(0),U,9)
- +6 IF NAME=""!'FILE!'RFILE
- QUIT
- +7 ;
- +8 IF FILE'=RFILE
- Begin DoDot:1
- +9 SET LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE)
- IF LDIF=""
- QUIT
- +10 SET UIR=$$FROOTDA^DIKCU(FILE,LDIF_"O")
- IF UIR=""
- QUIT
- End DoDot:1
- +11 IF '$TEST
- Begin DoDot:1
- +12 SET LDIF=0
- +13 SET UIR=$$FROOTDA^DIKCU(FILE,"O")
- IF UIR=""
- QUIT
- End DoDot:1
- +14 IF $GET(UIR)=""
- QUIT
- +15 SET UIR=UIR_""""_NAME_""""
- SET IROOT=UIR_")"
- +16 ;
- +17 SET S=0
- FOR
- SET S=$ORDER(^DD("IX",XR,11.1,"AC",S))
- IF 'S
- QUIT
- SET CRV=$ORDER(^(S,0))
- IF CRV
- Begin DoDot:1
- +18 IF $DATA(^DD("IX",XR,11.1,CRV,0))[0
- QUIT
- SET ORD=$PIECE(^(0),U)
- SET FIL=$PIECE(^(0),U,3)
- SET FLD=$PIECE(^(0),U,4)
- SET ML=$PIECE(^(0),U,5)
- +19 IF 'ORD
- QUIT
- +20 IF ML
- SET UIR=UIR_",$E(X("_ORD_"),1,"_ML_")"
- SET MAXL(ORD)=ML
- +21 IF '$TEST
- SET UIR=UIR_",X("_ORD_")"
- +22 IF FIL
- IF FLD
- SET SS=$GET(SS)+1
- SET SS(S)=FIL_U_FLD_$SELECT(ML:U_ML,1:"")
- End DoDot:1
- +23 ;
- +24 SET UIR=UIR_")"
- +25 QUIT
- +26 ;
- +27 ;===============================
- +28 ; WRAP(.Text,Width,Width1,Code)
- +29 ;===============================
- +30 ;Wrap the lines in array T
- +31 ;In:
- +32 ; .T = array of text; 1st line can be in T or T(0)
- +33 ; subsequent lines are in T(1),...,T(n)
- +34 ; WID = maximum length of each line (default = IOM[or 80]-1)
- +35 ; if < 0 : IOM-1+WID
- +36 ; WID1 = maximum length of line 1 (optional)
- +37 ; if "" : WID
- +38 ; if < 0 : IOM-1+WID1
- +39 ; COD = 1, if lines should NOT wrap on word boundaries
- +40 ;
- WRAP(T,WID,WID1,COD) ;Wrap the lines in the T array
- +1 IF '$DATA(T)
- QUIT
- +2 NEW E,J,P,T0,W
- +3 ;
- +4 SET WID=$GET(WID)\1
- +5 IF WID<1
- SET WID=$GET(IOM,80)-1+WID
- +6 IF WID<1
- SET WID=79
- +7 ;
- +8 SET W=$SELECT($GET(WID1):WID1\1,$GET(WID1)=0:$GET(IOM,80)-1,1:WID)
- +9 IF W<1
- SET W=$GET(IOM,80)-1+W
- +10 IF W<1
- SET W=79
- +11 ;
- +12 IF $DATA(T(0))[0
- SET T0=1
- SET T(0)=T
- +13 ;
- +14 ;Wrap at word boundaries
- +15 IF '$GET(COD)
- FOR J=0:1
- IF '$DATA(T(J))
- QUIT
- Begin DoDot:1
- +16 IF J=1
- SET W=WID
- +17 IF J
- SET T(J)=$$LD(T(J))
- +18 ;
- +19 ;Line must be split
- +20 IF $LENGTH(T(J))>W
- Begin DoDot:2
- +21 DO DOWNT
- +22 FOR P=$LENGTH(T(J)," "):-1:0
- IF $LENGTH($PIECE(T(J)," ",1,P))'>W
- QUIT
- +23 IF 'P
- SET T(J+1)=$EXTRACT(T(J),W+1,999)
- SET T(J)=$EXTRACT(T(J),1,W)
- +24 IF '$TEST
- SET T(J+1)=$$LD($PIECE(T(J)," ",P+1,999))
- SET T(J)=$$TR($PIECE(T(J)," ",1,P))
- End DoDot:2
- +25 ;
- +26 ;Or line must be joined with next
- +27 IF '$TEST
- IF $LENGTH(T(J))<W
- Begin DoDot:2
- +28 IF '$DATA(T(J+1))
- QUIT
- +29 IF T(J)]""
- IF T(J)'?.E1" "
- SET T(J)=T(J)_" "
- +30 SET T(J+1)=$$LD(T(J+1))
- +31 ;
- +32 FOR P=1:1:$LENGTH(T(J+1)," ")+1
- IF $LENGTH(T(J))+$LENGTH($PIECE(T(J+1)," ",1,P))>W
- QUIT
- +33 SET T(J)=$$TR(T(J)_$PIECE(T(J+1)," ",1,P-1))
- +34 SET T(J+1)=$$LD($PIECE(T(J+1)," ",P,999))
- +35 IF T(J+1)=""
- DO UPT
- SET J=J-1
- End DoDot:2
- End DoDot:1
- +36 ;
- +37 ;Or wrap to width
- +38 IF '$TEST
- FOR J=0:1
- IF '$DATA(T(J))
- QUIT
- Begin DoDot:1
- +39 IF J=1
- SET W=WID
- +40 ;
- +41 ;Line must be split
- +42 IF $LENGTH(T(J))>W
- Begin DoDot:2
- +43 DO DOWNT
- +44 SET T(J+1)=$EXTRACT(T(J),W+1,999)
- +45 SET T(J)=$EXTRACT(T(J),1,W)
- End DoDot:2
- +46 ;
- +47 ;Or joined with next
- +48 IF '$TEST
- IF $LENGTH(T(J))<W
- Begin DoDot:2
- +49 IF '$DATA(T(J+1))
- QUIT
- +50 SET E=W-$LENGTH(T(J))
- +51 SET T(J)=T(J)_$EXTRACT(T(J+1),1,E)
- +52 SET T(J+1)=$EXTRACT(T(J+1),E+1,999)
- +53 IF T(J+1)=""
- DO UPT
- SET J=J-1
- End DoDot:2
- End DoDot:1
- +54 ;
- +55 IF $GET(T0)
- SET T=T(0)
- KILL T(0)
- +56 QUIT
- +57 ;
- DOWNT ;Push the T array from element J+1 down
- +1 NEW K
- +2 FOR K=$ORDER(T(""),-1):-1:J+1
- SET T(K+1)=T(K)
- +3 SET T(J+1)=""
- +4 QUIT
- +5 ;
- UPT ;Pop the T array from element J+1 down
- +1 NEW K
- +2 FOR K=J+1:1:$ORDER(T(""),-1)-1
- SET T(K)=T(K+1)
- +3 KILL T($ORDER(T(""),-1))
- +4 QUIT
- +5 ;
- TR(X) ;Strip trailing spaces
- +1 IF $GET(X)=""
- QUIT X
- +2 NEW I
- +3 FOR I=$LENGTH(X):-1:0
- IF $EXTRACT(X,I)'=" "
- QUIT
- +4 QUIT $EXTRACT(X,1,I)
- +5 ;
- LD(X) ;Strip leading spaces
- +1 IF $GET(X)=""
- QUIT X
- +2 NEW I
- +3 FOR I=1:1:$LENGTH(X)+1
- IF $EXTRACT(X,I)'=" "
- QUIT
- +4 QUIT $EXTRACT(X,I,999)
- +5 ;
- ERR(ERR,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;Build an error message
- +1 NEW P,I,V
- +2 FOR I="FILE","IENS","FIELD",1,2,3
- SET V=$GET(@("DI"_I))
- IF V]""
- SET P(I)=V
- +3 DO BLD^DIALOG(ERR,.P,.P)
- +4 QUIT