DIEZ4 ;SFISC/MKO-COMPILE INPUT TEMPLATE, RECORD-LEVEL INDEXES ;2:15 PM 14 Jul 1999
;;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.
;
;Variables passed in through symbol table:
; DNM = Name of routine
; DRN(routine#) = "" : array of routine numbers
; DMAX = Maximum routine size
; DIEZTMP = Root of global that contains record-level index info
;
;Routine-wide variables
; T = Total byte count of current routine
; L = Last line number in current routine
; DP = file #
; DRN = routine #
; DIEZCNT = Count of xrefs processed in current routine (used as
; a line tag)
; DIEZAR(file#,xref#) = linetag^routine (returned)
; DIEZKEYR(file#,key#,uniqxref#) = Xn^routine
;
RECXR(DIEZAR) ;Build routines for record-level indexes
Q:'$D(@DIEZTMP@("R"))
N DIEZCNT,DIEZXR,DP
;
S DRN=$O(DRN(""),-1)+1
D NEWROU
;
S DP=0 F S DP=$O(@DIEZTMP@("R",DP)) Q:'DP D Q:$G(DIEZQ)
. S DIEZXR=0
. F S DIEZXR=$O(@DIEZTMP@("R",DP,DIEZXR)) Q:'DIEZXR D Q:$G(DIEZQ)
.. D GETXR(DIEZXR) Q:$G(DIEZQ)
Q:$G(DIEZQ)
D SAVE
Q
;
GETXR(DIEZXR) ;Get code for one index DIEZXR
N DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZO,DIEZSLOG
I T>DMAX D SAVE Q:$G(DIEZQ) D NEWROU
;
S DIEZCNT=$G(DIEZCNT)+1
S DIEZAR(DP,DIEZXR)=DIEZCNT_U_DNM_DRN
;
;Build code to call subroutine to set X array
D L(DIEZCNT_" N X,X1,X2 S DIXR="_DIEZXR_" D X"_DIEZCNT_"(U) K X2 M X2=X D X"_DIEZCNT_"(""F"") K X1 M X1=X")
;
;Build code to check for null subscripts
S DIEZNSS="",DIEZO=0
F S DIEZO=$O(@DIEZTMP@("R",DP,DIEZXR,DIEZO)) Q:'DIEZO D
. Q:'$G(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"SS"))
. I DIEZNSS="" S DIEZNSS="$G(X("_DIEZO_"))]"""""
. E S DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]"""""
I DIEZNSS]"" S DIEZNSS=" I "_DIEZNSS_" D"
E S DIEZNSS=" D"
;
;Store kill logic and condition
S DIEZKLOG=$G(@DIEZTMP@("R",DP,DIEZXR,"K"))
I DIEZKLOG'?."^" D
. D L(DIEZNSS)
. ;Build kill condition code
. S DIEZCOD=$G(@DIEZTMP@("R",DP,DIEZXR,"KC"))
. I DIEZCOD'?."^" D
.. D L(" . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1")
.. D L(" . "_DIEZCOD)
.. D L(" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND")
. ;Store kill logic
. D L(" . "_DIEZKLOG)
;
;Store set logic and condition
S DIEZSLOG=$G(@DIEZTMP@("R",DP,DIEZXR,"S"))
I DIEZSLOG'?."^" D
. D L(" K X M X=X2"_DIEZNSS)
. ;Build set condition code
. S DIEZCOD=$G(@DIEZTMP@("R",DP,DIEZXR,"SC"))
. I DIEZCOD'?."^" D
.. D L(" . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1")
.. D L(" . "_DIEZCOD)
.. D L(" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND")
. ;Store set logic
. D L(" . "_DIEZSLOG)
;
;Build code to check record level keys
D:$D(^DD("KEY","AU",DIEZXR)) BLDKCHK(DIEZXR)
D L(" Q")
;
;Build code to set X array
S DIEZF=$O(@DIEZTMP@("R",DP,DIEZXR,0))
D L("X"_DIEZCNT_"(DION) K X")
;
S DIEZO=0
F S DIEZO=$O(@DIEZTMP@("R",DP,DIEZXR,DIEZO)) Q:'DIEZO D BLDDEC(DIEZXR,DIEZO)
D L(" S X=$G(X("_DIEZF_"))")
D L(" Q")
Q
;
BLDDEC(DIEZXR,DIEZO) ;Build data extraction code
N CODE,NODE,TRANS
;
S CODE=$G(@DIEZTMP@("R",DP,DIEZXR,DIEZO)) Q:CODE?."^"
S TRANS=$G(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"T"))
I TRANS'?."^" D
. D L(" "_CODE)
. D DOTLINE(" I $D(X)#2 "_TRANS)
. D L(" S:$D(X)#2 X("_DIEZO_")=X")
E I $D(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"F"))#2,CODE?1"S X=".E D
. D L(" S X("_DIEZO_")"_$E(CODE,4,999))
E D
. D L(" "_CODE)
. D L(" S:$D(X)#2 X("_DIEZO_")=X")
Q
;
BLDKCHK(DIEZUI) ;Build code to check key for xref
N DIEZKLST,DIEZMAXL,DIEZUIR,I
;
D XRINFO^DIKCU2(DIEZUI,.DIEZUIR,"",.DIEZMAXL)
;
;Get list of keys with this uniqueness index
S DIEZKLST="",I=0
S I=0 F S I=$O(^DD("KEY","AU",DIEZUI,I)) Q:'I S DIEZKLST=I_","
Q:DIEZKLST=""
S DIEZKLST=$E(DIEZKLST,1,$L(DIEZKLST)-1)
;
D L(" . I $G(DIEXEC)[""K"" D")
D L(" .. N DIMAXL,DIUIR")
D L(" .. S DIUIR=$NA("_DIEZUIR_") Q:'$D(@DIUIR)")
;
;Build code to set DIMAXL(order#)=maxLength
I $D(DIEZMAXL) D
. N ORD,X
. S X="S ",ORD=0
. F S ORD=$O(DIEZMAXL(ORD)) Q:'ORD D
.. S X=X_"DIMAXL("_ORD_")="_DIEZMAXL(ORD)_","
. I X?.E1"," D L(" .. "_$E(X,1,$L(X)-1))
;
D L(" .. I '$$UNIQUE^DIE17(.X,.DA,DIUIR,""X"_DIEZCNT_U_DNM_DRN_""""_$S($D(DIEZMAXL):",.DIMAXL",1:"")_") N I F I="_DIEZKLST_" S DIKEY("_DP_",I,DIIENS)=""""")
Q
;
L(X) ;Add CODE to ^UTILITY
S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2
Q
;
DOTLINE(X) ;
I X[" Q"!(X[" Q:") D
. D L(" D"),L(" ."_X)
E D L(X)
Q
;
NEWROU ;Start a new routine
K ^UTILITY($J,0)
S ^UTILITY($J,0,1)=DNM_DRN_" ; ;"_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),T=$L(^(1))
S ^UTILITY($J,0,2)=" ;;",T=T+$L(^(2))
S L=2,DIEZCNT=0
Q
;
SAVE ;Get the next available routine number
N DQ
F DQ=DRN+1:1 Q:'$D(DRN(DQ))
;
;Save current routine
D SAVE^DIEZ1 Q:$G(DIEZQ)
K ^UTILITY($J,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEZ4 5081 printed Dec 13, 2024@02:47:31 Page 2
DIEZ4 ;SFISC/MKO-COMPILE INPUT TEMPLATE, RECORD-LEVEL INDEXES ;2:15 PM 14 Jul 1999
+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 ;Variables passed in through symbol table:
+8 ; DNM = Name of routine
+9 ; DRN(routine#) = "" : array of routine numbers
+10 ; DMAX = Maximum routine size
+11 ; DIEZTMP = Root of global that contains record-level index info
+12 ;
+13 ;Routine-wide variables
+14 ; T = Total byte count of current routine
+15 ; L = Last line number in current routine
+16 ; DP = file #
+17 ; DRN = routine #
+18 ; DIEZCNT = Count of xrefs processed in current routine (used as
+19 ; a line tag)
+20 ; DIEZAR(file#,xref#) = linetag^routine (returned)
+21 ; DIEZKEYR(file#,key#,uniqxref#) = Xn^routine
+22 ;
RECXR(DIEZAR) ;Build routines for record-level indexes
+1 if '$DATA(@DIEZTMP@("R"))
QUIT
+2 NEW DIEZCNT,DIEZXR,DP
+3 ;
+4 SET DRN=$ORDER(DRN(""),-1)+1
+5 DO NEWROU
+6 ;
+7 SET DP=0
FOR
SET DP=$ORDER(@DIEZTMP@("R",DP))
if 'DP
QUIT
Begin DoDot:1
+8 SET DIEZXR=0
+9 FOR
SET DIEZXR=$ORDER(@DIEZTMP@("R",DP,DIEZXR))
if 'DIEZXR
QUIT
Begin DoDot:2
+10 DO GETXR(DIEZXR)
if $GET(DIEZQ)
QUIT
End DoDot:2
if $GET(DIEZQ)
QUIT
End DoDot:1
if $GET(DIEZQ)
QUIT
+11 if $GET(DIEZQ)
QUIT
+12 DO SAVE
+13 QUIT
+14 ;
GETXR(DIEZXR) ;Get code for one index DIEZXR
+1 NEW DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZO,DIEZSLOG
+2 IF T>DMAX
DO SAVE
if $GET(DIEZQ)
QUIT
DO NEWROU
+3 ;
+4 SET DIEZCNT=$GET(DIEZCNT)+1
+5 SET DIEZAR(DP,DIEZXR)=DIEZCNT_U_DNM_DRN
+6 ;
+7 ;Build code to call subroutine to set X array
+8 DO L(DIEZCNT_" N X,X1,X2 S DIXR="_DIEZXR_" D X"_DIEZCNT_"(U) K X2 M X2=X D X"_DIEZCNT_"(""F"") K X1 M X1=X")
+9 ;
+10 ;Build code to check for null subscripts
+11 SET DIEZNSS=""
SET DIEZO=0
+12 FOR
SET DIEZO=$ORDER(@DIEZTMP@("R",DP,DIEZXR,DIEZO))
if 'DIEZO
QUIT
Begin DoDot:1
+13 if '$GET(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"SS"))
QUIT
+14 IF DIEZNSS=""
SET DIEZNSS="$G(X("_DIEZO_"))]"""""
+15 IF '$TEST
SET DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]"""""
End DoDot:1
+16 IF DIEZNSS]""
SET DIEZNSS=" I "_DIEZNSS_" D"
+17 IF '$TEST
SET DIEZNSS=" D"
+18 ;
+19 ;Store kill logic and condition
+20 SET DIEZKLOG=$GET(@DIEZTMP@("R",DP,DIEZXR,"K"))
+21 IF DIEZKLOG'?."^"
Begin DoDot:1
+22 DO L(DIEZNSS)
+23 ;Build kill condition code
+24 SET DIEZCOD=$GET(@DIEZTMP@("R",DP,DIEZXR,"KC"))
+25 IF DIEZCOD'?."^"
Begin DoDot:2
+26 DO L(" . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1")
+27 DO L(" . "_DIEZCOD)
+28 DO L(" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND")
End DoDot:2
+29 ;Store kill logic
+30 DO L(" . "_DIEZKLOG)
End DoDot:1
+31 ;
+32 ;Store set logic and condition
+33 SET DIEZSLOG=$GET(@DIEZTMP@("R",DP,DIEZXR,"S"))
+34 IF DIEZSLOG'?."^"
Begin DoDot:1
+35 DO L(" K X M X=X2"_DIEZNSS)
+36 ;Build set condition code
+37 SET DIEZCOD=$GET(@DIEZTMP@("R",DP,DIEZXR,"SC"))
+38 IF DIEZCOD'?."^"
Begin DoDot:2
+39 DO L(" . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1")
+40 DO L(" . "_DIEZCOD)
+41 DO L(" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND")
End DoDot:2
+42 ;Store set logic
+43 DO L(" . "_DIEZSLOG)
End DoDot:1
+44 ;
+45 ;Build code to check record level keys
+46 if $DATA(^DD("KEY","AU",DIEZXR))
DO BLDKCHK(DIEZXR)
+47 DO L(" Q")
+48 ;
+49 ;Build code to set X array
+50 SET DIEZF=$ORDER(@DIEZTMP@("R",DP,DIEZXR,0))
+51 DO L("X"_DIEZCNT_"(DION) K X")
+52 ;
+53 SET DIEZO=0
+54 FOR
SET DIEZO=$ORDER(@DIEZTMP@("R",DP,DIEZXR,DIEZO))
if 'DIEZO
QUIT
DO BLDDEC(DIEZXR,DIEZO)
+55 DO L(" S X=$G(X("_DIEZF_"))")
+56 DO L(" Q")
+57 QUIT
+58 ;
BLDDEC(DIEZXR,DIEZO) ;Build data extraction code
+1 NEW CODE,NODE,TRANS
+2 ;
+3 SET CODE=$GET(@DIEZTMP@("R",DP,DIEZXR,DIEZO))
if CODE?."^"
QUIT
+4 SET TRANS=$GET(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"T"))
+5 IF TRANS'?."^"
Begin DoDot:1
+6 DO L(" "_CODE)
+7 DO DOTLINE(" I $D(X)#2 "_TRANS)
+8 DO L(" S:$D(X)#2 X("_DIEZO_")=X")
End DoDot:1
+9 IF '$TEST
IF $DATA(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"F"))#2
IF CODE?1"S X=".E
Begin DoDot:1
+10 DO L(" S X("_DIEZO_")"_$EXTRACT(CODE,4,999))
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 DO L(" "_CODE)
+13 DO L(" S:$D(X)#2 X("_DIEZO_")=X")
End DoDot:1
+14 QUIT
+15 ;
BLDKCHK(DIEZUI) ;Build code to check key for xref
+1 NEW DIEZKLST,DIEZMAXL,DIEZUIR,I
+2 ;
+3 DO XRINFO^DIKCU2(DIEZUI,.DIEZUIR,"",.DIEZMAXL)
+4 ;
+5 ;Get list of keys with this uniqueness index
+6 SET DIEZKLST=""
SET I=0
+7 SET I=0
FOR
SET I=$ORDER(^DD("KEY","AU",DIEZUI,I))
if 'I
QUIT
SET DIEZKLST=I_","
+8 if DIEZKLST=""
QUIT
+9 SET DIEZKLST=$EXTRACT(DIEZKLST,1,$LENGTH(DIEZKLST)-1)
+10 ;
+11 DO L(" . I $G(DIEXEC)[""K"" D")
+12 DO L(" .. N DIMAXL,DIUIR")
+13 DO L(" .. S DIUIR=$NA("_DIEZUIR_") Q:'$D(@DIUIR)")
+14 ;
+15 ;Build code to set DIMAXL(order#)=maxLength
+16 IF $DATA(DIEZMAXL)
Begin DoDot:1
+17 NEW ORD,X
+18 SET X="S "
SET ORD=0
+19 FOR
SET ORD=$ORDER(DIEZMAXL(ORD))
if 'ORD
QUIT
Begin DoDot:2
+20 SET X=X_"DIMAXL("_ORD_")="_DIEZMAXL(ORD)_","
End DoDot:2
+21 IF X?.E1","
DO L(" .. "_$EXTRACT(X,1,$LENGTH(X)-1))
End DoDot:1
+22 ;
+23 DO L(" .. I '$$UNIQUE^DIE17(.X,.DA,DIUIR,""X"_DIEZCNT_U_DNM_DRN_""""_$SELECT($DATA(DIEZMAXL):",.DIMAXL",1:"")_") N I F I="_DIEZKLST_" S DIKEY("_DP_",I,DIIENS)=""""")
+24 QUIT
+25 ;
L(X) ;Add CODE to ^UTILITY
+1 SET L=L+1
SET ^UTILITY($JOB,0,L)=X
SET T=T+$LENGTH(X)+2
+2 QUIT
+3 ;
DOTLINE(X) ;
+1 IF X[" Q"!(X[" Q:")
Begin DoDot:1
+2 DO L(" D")
DO L(" ."_X)
End DoDot:1
+3 IF '$TEST
DO L(X)
+4 QUIT
+5 ;
NEWROU ;Start a new routine
+1 KILL ^UTILITY($JOB,0)
+2 SET ^UTILITY($JOB,0,1)=DNM_DRN_" ; ;"_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
SET T=$LENGTH(^(1))
+3 SET ^UTILITY($JOB,0,2)=" ;;"
SET T=T+$LENGTH(^(2))
+4 SET L=2
SET DIEZCNT=0
+5 QUIT
+6 ;
SAVE ;Get the next available routine number
+1 NEW DQ
+2 FOR DQ=DRN+1:1
if '$DATA(DRN(DQ))
QUIT
+3 ;
+4 ;Save current routine
+5 DO SAVE^DIEZ1
if $GET(DIEZQ)
QUIT
+6 KILL ^UTILITY($JOB,0)
+7 QUIT
