DIEZ0 ;SFISC/GFT - COMPILE INPUT TEMPLATE ;5DEC2012
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;
D L
DL S DQ=0,DK=0,DQFF=0
MR S DK=DK+1,DH=$P(DR,";",DK),DI=$P(DH,":",1),(DIEZP,DIEZDUP,DIEZR)="" G:'DI K:DI=0,PB S DPR=$P(DH,"//",2,99),DM=+DI S:DPR]"" DI=$P(DI,"//",1),DH=""
G K:DM=DI S Y=$P(DI,DM,2,99) G MR:Y=""!'$D(^DD(DP,DM,0)) F %=1:1 S X=$P(Y,$C(126),%) Q:X="" S:X="d" DIEZDUP=X S:X="R" DIEZR=X S:X'="d"&(X'="R")&(X'="T") DIEZP=X D:X="T"
.I $D(^DD(DP,DM,.1)) S DIEZP=^(.1) Q
.I +$P(^DD(DP,DM,0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",$D(^(.1)) S DIEZP=^(.1)
.Q
S (DI,DM)=+DI G S
K S DM=$P(DH,":",2),DM=$S(DM:DM,1:+DI) I DI,$D(^DD(DP,+DI)) G S
NX ;
S DI=$O(^DD(DP,+DI)),DIEZP="" S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM
S S Y=^DD(DP,+DI,0),DV=$P(Y,U,2)_$E("#",Y["DINUM")_DIEZR_DIEZDUP ;**CCO/NI FIELD NAME (THRU NEXT 2 LINES)
S X=$S(DIEZP=""&'DV:"$$LABEL^DIALOGZ(DP,DIFLD)",1:""""_DIEZP_"""")
S DW=$P(Y,U,4) G NX:$A(DW)=32 I T>DMAX D SV G:DIEZQ K^DIEZ2 G S
W:'$G(DIEZS) "." S DQ=DQ+1,DI=+DI,DU=$P(Y,U,3),%=" S "
K DIEZOT I DV["O",$D(^(2)) D O^DIEZ2
I DQFF S %=" D:$D(DG)>9 F^DIE17,DE S DQ="_DQ_",",DQFF=0
I DV S Y=X,X=DQ_%_"D=0 K DE(1) ;"_DI D L,DRN G MUL^DIEZ2
VARS S ^UTILITY($J,U,$P(DW,";",1),$P(DW,";",2),DQ)="",T=T+35,X=DQ_%_"DW="""_DW_""",DV="""_DV_""",DU="""",DIFLD="_DI_",DLB="_X D L ;**CCO/NI COMPILE 'SET DLB=$$LABEL^DIALOGZ...' RATHER THAN FIELD NAME, SO IT WORKS FOR ANY LANGUAGE
I $D(DIEZOT) S X=DIEZOT D L K DIEZOT
S DIEZXREF=$O(^DD("IX","F",DP,DI,0))
I $O(^DD(DP,DI,1,0))>0!(DV["a")!DIEZXREF D
. S DQFF=1,X=" S DE(DW)=""C"_DQ_U_DNM_DRN_""""
. S:DIEZXREF X=X_",DE(DW,""INDEX"")=1"
. ;Determine whether this field is part of a field-level key.
. ;Also, build list: DIEZKEY(uniquenessIndex)=""
. ;for those indexes that are uniqueness indexes for keys.
. N DIEZK,DIEZUI
. K DIEZKEY S DIEZK=0
. F S DIEZK=$O(^DD("KEY","F",DP,DI,DIEZK)) Q:'DIEZK D
.. S DIEZUI=$P($G(^DD("KEY",DIEZK,0)),U,4) Q:'DIEZUI
.. S:$P($G(^DD("IX",DIEZUI,0)),U,6)="F" DIEZKEY(DIEZUI)=""
. S:$D(DIEZKEY) X=X_",DE(DW,""KEY"")=""$$K"_DQ_""""
. D L
K DIEZXREF
X D PR,XREF^DIEZ2:DQFF
I DPR?1"//".E S %=""
TYPE E I DV["t" D
. I DPR?1"/".E S %=$$VALEXTS^DIETLIBF(DP,DI)
. E S %=$$VALEXT^DIETLIBF(DP,DI)
E D
. S %=$P(Y,U,5,99),X=$F(%,"%DT=""") I X,DPR?1"/".E S Y=$F(%,"E",X) I Y S %=$E(%,1,Y-2)_$E(%,Y,999)
D AF^DIEZ2 S X="X"_DQ_" " I "Q"[% S X=X_"Q" D L G NX
S X=X_% D L I DV["F"!(DV["t") S X=" I $D(X),X'?.ANP K X" D L
S X=" Q" D L S X=" ;" D L G NX
;
PB I DH="" S:'$D(DOV(DL)) DOV(DL)=0 S DOV(DL)=$O(^DIE(DIEZ,"DR",DIER,DP,DOV(DL))) S:DOV(DL)="" DOV(DL)=-1 G UP:DOV(DL)<0 S DR=^(DOV(DL)),DK=0 G MR
S DQ=DQ+1 I DH?1"@".N S X=DQ_" S DQ="_(DQ+1)_" ;"_DH,^UTILITY($J,"AB",DIEZAB,DH)=DQ_U_DNM_DRN G M
S X=DQ_" D:$D(DG)>9 F^DIE17,DE S Y=U,DQ="_DQ_" " I "Q"[DH S X=X_"G A" G M
I DH?1"^".E S F=0,X=X_$P(DH,U,5,999),Q=$P(DH,U,1,3) D L,DRN,QFF^DIEZ2,DIERN^DIEZ2 S X=" S DGO=""^"_DNM_%_""",DC="_Q_" G DIEZ^DIE0",DRN(%)=$P(DH,U,2)_U_DIERN_U_$P(DH,U,3)_U_U_DQ_U_DRN D L S X="R"_DQ_" D DE G A" D L S X=" ;" G M
S X=X_"D X"_DQ_" D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)=""F"",DW=DQ G OUT^DIE17" D L S X="X"_DQ_" "_DH D L S X=" Q"
M D L G MR
;
UP S DQ=DQ+1,X=DQ_" G "_(DL>1)_"^DIE17" D L,^DIEZ1 G:DIEZQ K^DIEZ2 S Y=0
LV S Y=$O(DRN(Y)) S:Y="" Y=-1 I Y<0 G ^DIEZ2
S X=DRN(Y) G LV:X=U S DRN=Y,DP=+X,DIER=$P(X,U,2),DL=DIER\1,DIE=U_$P(X,U,3),DIEZL=+$P(X,U,4),DIEZAB=$P(X,U,5)_U_DNM_$P(X,U,6),DR=$S($D(^DIE(DIEZ,"DR",DIER,DP)):^(DP),1:"0:9999999"),DRN(Y)=U D N S:+DR=.01!(DR?1"0:".E) ^(3)=^(3)_"+D G B" G DL
;
PR ;
D DU^DIEZ2:DU]"" S X=" G RE" I DW="0;1",DL>1,DQ=1 S X=X_":'D S DQ=2 G 2"
D PR^DIEZ2:DPR]""
L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 S:X?1N.E T=T+15 Q
;
SV D DRN
S X=DQ+1_" D:$D(DG)>9 F^DIE17 G ^"_DNM_%,DQ=% D L,^DIEZ1 Q:DIEZQ
N G NEWROU^DIEZ
;
DRN F %=DRN+1:1 Q:'$D(DRN(%))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEZ0 4158 printed Oct 16, 2024@18:48 Page 2
DIEZ0 ;SFISC/GFT - COMPILE INPUT TEMPLATE ;5DEC2012
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 DO L
DL SET DQ=0
SET DK=0
SET DQFF=0
MR SET DK=DK+1
SET DH=$PIECE(DR,";",DK)
SET DI=$PIECE(DH,":",1)
SET (DIEZP,DIEZDUP,DIEZR)=""
if 'DI
if DI=0
GOTO K
GOTO PB
SET DPR=$PIECE(DH,"//",2,99)
SET DM=+DI
if DPR]""
SET DI=$PIECE(DI,"//",1)
SET DH=""
+1 if DM=DI
GOTO K
SET Y=$PIECE(DI,DM,2,99)
if Y=""!'$DATA(^DD(DP,DM,0))
GOTO MR
FOR %=1:1
SET X=$PIECE(Y,$CHAR(126),%)
if X=""
QUIT
if X="d"
SET DIEZDUP=X
if X="R"
SET DIEZR=X
if X'="d"&(X'="R")&(X'="T")
SET DIEZP=X
if X="T"
Begin DoDot:1
+2 IF $DATA(^DD(DP,DM,.1))
SET DIEZP=^(.1)
QUIT
+3 IF +$PIECE(^DD(DP,DM,0),U,2)
IF $PIECE(^DD(+$PIECE(^(0),U,2),.01,0),U,2)["W"
IF $DATA(^(.1))
SET DIEZP=^(.1)
+4 QUIT
End DoDot:1
+5 SET (DI,DM)=+DI
GOTO S
K SET DM=$PIECE(DH,":",2)
SET DM=$SELECT(DM:DM,1:+DI)
IF DI
IF $DATA(^DD(DP,+DI))
GOTO S
NX ;
+1 SET DI=$ORDER(^DD(DP,+DI))
SET DIEZP=""
if DI=""
SET DI=-1
if DI'>0
GOTO MR
if DI>DM
GOTO MR
S ;**CCO/NI FIELD NAME (THRU NEXT 2 LINES)
SET Y=^DD(DP,+DI,0)
SET DV=$PIECE(Y,U,2)_$EXTRACT("#",Y["DINUM")_DIEZR_DIEZDUP
+1 SET X=$SELECT(DIEZP=""&'DV:"$$LABEL^DIALOGZ(DP,DIFLD)",1:""""_DIEZP_"""")
+2 SET DW=$PIECE(Y,U,4)
if $ASCII(DW)=32
GOTO NX
IF T>DMAX
DO SV
if DIEZQ
GOTO K^DIEZ2
GOTO S
+3 if '$GET(DIEZS)
WRITE "."
SET DQ=DQ+1
SET DI=+DI
SET DU=$PIECE(Y,U,3)
SET %=" S "
+4 KILL DIEZOT
IF DV["O"
IF $DATA(^(2))
DO O^DIEZ2
+5 IF DQFF
SET %=" D:$D(DG)>9 F^DIE17,DE S DQ="_DQ_","
SET DQFF=0
+6 IF DV
SET Y=X
SET X=DQ_%_"D=0 K DE(1) ;"_DI
DO L
DO DRN
GOTO MUL^DIEZ2
VARS ;**CCO/NI COMPILE 'SET DLB=$$LABEL^DIALOGZ...' RATHER THAN FIELD NAME, SO IT WORKS FOR ANY LANGUAGE
SET ^UTILITY($JOB,U,$PIECE(DW,";",1),$PIECE(DW,";",2),DQ)=""
SET T=T+35
SET X=DQ_%_"DW="""_DW_""",DV="""_DV_""",DU="""",DIFLD="_DI_",DLB="_X
DO L
+1 IF $DATA(DIEZOT)
SET X=DIEZOT
DO L
KILL DIEZOT
+2 SET DIEZXREF=$ORDER(^DD("IX","F",DP,DI,0))
+3 IF $ORDER(^DD(DP,DI,1,0))>0!(DV["a")!DIEZXREF
Begin DoDot:1
+4 SET DQFF=1
SET X=" S DE(DW)=""C"_DQ_U_DNM_DRN_""""
+5 if DIEZXREF
SET X=X_",DE(DW,""INDEX"")=1"
+6 ;Determine whether this field is part of a field-level key.
+7 ;Also, build list: DIEZKEY(uniquenessIndex)=""
+8 ;for those indexes that are uniqueness indexes for keys.
+9 NEW DIEZK,DIEZUI
+10 KILL DIEZKEY
SET DIEZK=0
+11 FOR
SET DIEZK=$ORDER(^DD("KEY","F",DP,DI,DIEZK))
if 'DIEZK
QUIT
Begin DoDot:2
+12 SET DIEZUI=$PIECE($GET(^DD("KEY",DIEZK,0)),U,4)
if 'DIEZUI
QUIT
+13 if $PIECE($GET(^DD("IX",DIEZUI,0)),U,6)="F"
SET DIEZKEY(DIEZUI)=""
End DoDot:2
+14 if $DATA(DIEZKEY)
SET X=X_",DE(DW,""KEY"")=""$$K"_DQ_""""
+15 DO L
End DoDot:1
+16 KILL DIEZXREF
X DO PR
if DQFF
DO XREF^DIEZ2
+1 IF DPR?1"//".E
SET %=""
TYPE IF '$TEST
IF DV["t"
Begin DoDot:1
+1 IF DPR?1"/".E
SET %=$$VALEXTS^DIETLIBF(DP,DI)
+2 IF '$TEST
SET %=$$VALEXT^DIETLIBF(DP,DI)
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 SET %=$PIECE(Y,U,5,99)
SET X=$FIND(%,"%DT=""")
IF X
IF DPR?1"/".E
SET Y=$FIND(%,"E",X)
IF Y
SET %=$EXTRACT(%,1,Y-2)_$EXTRACT(%,Y,999)
End DoDot:1
+5 DO AF^DIEZ2
SET X="X"_DQ_" "
IF "Q"[%
SET X=X_"Q"
DO L
GOTO NX
+6 SET X=X_%
DO L
IF DV["F"!(DV["t")
SET X=" I $D(X),X'?.ANP K X"
DO L
+7 SET X=" Q"
DO L
SET X=" ;"
DO L
GOTO NX
+8 ;
PB IF DH=""
if '$DATA(DOV(DL))
SET DOV(DL)=0
SET DOV(DL)=$ORDER(^DIE(DIEZ,"DR",DIER,DP,DOV(DL)))
if DOV(DL)=""
SET DOV(DL)=-1
if DOV(DL)<0
GOTO UP
SET DR=^(DOV(DL))
SET DK=0
GOTO MR
+1 SET DQ=DQ+1
IF DH?1"@".N
SET X=DQ_" S DQ="_(DQ+1)_" ;"_DH
SET ^UTILITY($JOB,"AB",DIEZAB,DH)=DQ_U_DNM_DRN
GOTO M
+2 SET X=DQ_" D:$D(DG)>9 F^DIE17,DE S Y=U,DQ="_DQ_" "
IF "Q"[DH
SET X=X_"G A"
GOTO M
+3 IF DH?1"^".E
SET F=0
SET X=X_$PIECE(DH,U,5,999)
SET Q=$PIECE(DH,U,1,3)
DO L
DO DRN
DO QFF^DIEZ2
DO DIERN^DIEZ2
SET X=" S DGO=""^"_DNM_%_""",DC="_Q_" G DIEZ^DIE0"
SET DRN(%)=$PIECE(DH,U,2)_U_DIERN_U_$PIECE(DH,U,3)_U_U_DQ_U_DRN
DO L
SET X="R"_DQ_" D DE G A"
DO L
SET X=" ;"
GOTO M
+4 SET X=X_"D X"_DQ_" D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)=""F"",DW=DQ G OUT^DIE17"
DO L
SET X="X"_DQ_" "_DH
DO L
SET X=" Q"
M DO L
GOTO MR
+1 ;
UP SET DQ=DQ+1
SET X=DQ_" G "_(DL>1)_"^DIE17"
DO L
DO ^DIEZ1
if DIEZQ
GOTO K^DIEZ2
SET Y=0
LV SET Y=$ORDER(DRN(Y))
if Y=""
SET Y=-1
IF Y<0
GOTO ^DIEZ2
+1 SET X=DRN(Y)
if X=U
GOTO LV
SET DRN=Y
SET DP=+X
SET DIER=$PIECE(X,U,2)
SET DL=DIER\1
SET DIE=U_$PIECE(X,U,3)
SET DIEZL=+$PIECE(X,U,4)
SET DIEZAB=$PIECE(X,U,5)_U_DNM_$PIECE(X,U,6)
SET DR=$SELECT($DATA(^DIE(DIEZ,"DR",DIER,DP)):^(DP),1:"0:9999999")
SET DRN(Y)=U
DO N
if +DR=.01!(DR?1"0
SET ^(3)=^(3)_"+D G B"
GOTO DL
+2 ;
PR ;
+1 if DU]""
DO DU^DIEZ2
SET X=" G RE"
IF DW="0;1"
IF DL>1
IF DQ=1
SET X=X_":'D S DQ=2 G 2"
+2 if DPR]""
DO PR^DIEZ2
L SET L=L+1
SET ^UTILITY($JOB,0,L)=X
SET T=T+$LENGTH(X)+2
if X?1N.E
SET T=T+15
QUIT
+1 ;
SV DO DRN
+1 SET X=DQ+1_" D:$D(DG)>9 F^DIE17 G ^"_DNM_%
SET DQ=%
DO L
DO ^DIEZ1
if DIEZQ
QUIT
N GOTO NEWROU^DIEZ
+1 ;
DRN FOR %=DRN+1:1
if '$DATA(DRN(%))
QUIT
