DIKCU2 ;SFISC/MKO-ARRAY COMPARE, TEXT MANIPULATION ;2:40 PM 28 Jan 1998
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
;===============================
; $$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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCU2 5576 printed Dec 13, 2024@02:48:52 Page 2
DIKCU2 ;SFISC/MKO-ARRAY COMPARE, TEXT MANIPULATION ;2:40 PM 28 Jan 1998
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 ;===============================
+8 ; $$GCMP(ArrayName1,ArrayName2)
+9 ;===============================
+10 ;Compare the contents of two arrays
+11 ;In:
+12 ; DIKCU2A0 = Name of array 1
+13 ; DIKCU2B0 = Name of array 2
+14 ;Returns: 1 if equal, 0 if unequal
+15 ;
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
