- DIEZ ;SFISC/GFT - COMPILE INPUT TEMPLATE ; Nov 30, 2012
- ;;22.2;VA FileMan;**14,18**;Jan 05, 2016;Build 2
- ;;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.
- ;
- I $G(DUZ(0))'="@" W:$D(^DI(.84,0)) $C(7),$$EZBLD^DIALOG(101) G K
- EN1 D:'$D(DISYS) OS^DII
- I '$D(^DD("OS",DISYS,"ZS")) W $$EZBLD^DIALOG(820),$C(7) G K
- S U="^" S:'$G(DTIME) DTIME=300 N L,DNM
- D SIZ^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!('X) K S DMAX=X Q:$D(DIX)
- TEM K DIC S DIC="^DIE(",DIC(0)="AEQ",DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,^(""ROU"")",DIC("S")="I Y'<1" D ^DIC G:'$D(^DIE(+Y,"DR")) K S DIPZ=+Y
- D RNM^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!(X="") K S DNM=X K DIC
- W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G:'Y!($D(DIRUT)) K
- S X=DNM,Y=DIPZ K DIPZ
- EN ; compile INPUT template
- ;INPUT: X=name of routine for compiling, Y=ien of INPUT template
- D:'$D(DISYS) OS^DII ;p18
- W:'$G(DIEZS) ! K ^UTILITY($J),DRN
- N L,DIEZQ,DIR S DMAX=DMAX-2150,DNM=X,DIEZ=+Y,DRN="",DRD=0,DIEZQ=0
- D DT^DICRW,DELETROU(DNM) S X=-1 ;p14
- S DP=$P(^DIE(DIEZ,0),U,4),DIE=^DIC(DP,0,"GL")
- I '$D(^DIE(DIEZ,"DR",1,DP)) S ^DIE(DIEZ,"DR",1,DP)=^DIE(DIEZ,"DR")
- ;D DT^DICRW S X=-1 ;p14 move this line before DELETROU to define DISYS
- K T S T(1)=$P(^DIE(DIEZ,0),U),T(2)=$$EZBLD^DIALOG(8033),T(3)=DP D BLD^DIALOG(8024,.T,"","DIR") W:'$G(DIEZS) !,DIR K T
- D UNCAF(DIEZ)
- K DOV,^DIE(DIEZ,"RD"),DR S DR=^("DR",1,DP),(DIER,DL)=1,DIEZL=0,DIEZAB=U
- D NEWROU F %=0:0 S %=$O(^DIE(DIEZ,"DR",99,%)) Q:%="" F %Y=0:0 S %Y=$O(^DIE(DIEZ,"DR",99,%,%Y)) Q:%Y="" S F=0,Q=^DIE(DIEZ,"DR",99,%,%Y) D QFF^DIEZ2 S X=" S DR(99,"_%_","_%Y_")="_Q D L^DIEZ2
- S X=" N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1(""DIEZ"")" D L^DIEZ2
- S X=" M DIEZAR=^DIE("_DIEZ_",""AR"") S DICRREC=""TRIG^DIE17""" D L^DIEZ2
- N DIEZTMP S DIEZTMP=$$GETTMP^DIKC1("DIEZ")
- S X=" S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_"","",DIEZ="_DIEZ_",U=""^""" G ^DIEZ0
- ;
- NEWROU ;
- K ^UTILITY($J,0) S DQ=0,T=99,L=3
- S ^UTILITY($J,0,1)=DNM_DRN_" ; "_$P("GENERATED FROM '"_$P(^DIE(DIEZ,0),U,1)_"' INPUT TEMPLATE(#"_DIEZ_"), FILE "_DP,U,DRN="")_";"_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
- S ^UTILITY($J,0,2)=" D DE G BEGIN"
- S ^UTILITY($J,0,3)="BEGIN S DNM="""_DNM_DRN_""",DQ=1"
- I '$D(DRN(+DRN)) S DRN(+DRN)=U
- Q
- ;
- EN2(Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZZMSG) ;Silent or Talking with parameter passing
- ;and optionally return list of routines built and if successful
- ;IEN,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY
- ;Y=TEMPLATE IEN (required)
- ;FLAGS="T"alk (optional)
- ;X=ROUTINE NAME (required)
- ;DMAX=ROUTINE SIZE (optional)
- ;DIEZRLA=ROUTINE LIST ARRAY, by value (optional)
- ;DIEZZMSG=MESSAGE ARRAY (optional) (default ^TMP)
- ;*
- ;DIEZS will be used to indicate "silent" if set to 1
- ;Write statements are made conditional, if not "silent"
- ;*
- N DIEZS,DNM,DIQUIET,DIEZRIEN,DIEZRLAZ,DIEZRLAF
- N DIK,DIC,%I,DICS
- S DIEZS=$G(DIEZFLGS)'["T"
- S:DIEZS DIQUIET=1
- I '$D(DIFM) N DIFM S DIFM=1 D
- .N Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZS
- .D INIZE^DIEFU
- I $G(Y)'>0 D BLD^DIALOG(1700,"IEN for Edit Template missing or invalid") G EN2E
- I '$D(^DIE(Y,0)) D BLD^DIALOG(1700,"No Edit Template on file with IEN="_Y) G EN2E
- I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing this Edit Template, IEN="_Y) G EN2E
- I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E
- I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E
- S DIEZRLA=$G(DIEZRLA,"DIEZRLAZ"),DIEZRIEN=Y
- S:DIEZRLA="" DIEZRLA="DIEZRLAZ" S:$G(DMAX)<2500!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU")
- S DIEZRLAF=""
- K @DIEZRLA
- D EN
- G:'DIEZS!(DIEZRLAF) EN2E
- D BLD^DIALOG(1700,"Compiling Edit Template (IEN="_DIEZRIEN_")"_$S(DIEZRLAF=0:", routine name too long",1:""))
- EN2E I 'DIEZS D MSG^DIALOG() Q
- I $G(DIEZZMSG)]"" D CALLOUT^DIEFU(DIEZZMSG)
- Q
- ;
- RECOMP S DIX=1 D DIEZ Q:'$D(DIX) N DIMAX S DIMAX=DMAX
- F DIX=0:0 S DIX=$O(^DIE(DIX)) Q:DIX'>0 I $D(^(DIX,0)),$D(^("ROU")) S %=$P(^(0),"^",1),X=$E(^("ROU"),2,99) I X]"" S Y=DIX,DMAX=DIMAX D EN
- ;
- K K %,DDH,DIC,DIX,DIPZ,DMAX,DNM,DTOUT,DIRUT,DIROUT,DUOUT,X,Y Q
- ;DIALOG #101 'only those with programmer's access'
- ; #820 'no way to save routines on the system'
- ; #8020 'Should the compilation run now?'
- ; #8024 'Compiling template name Input template of file n'
- ; #8033 'Input template'
- UNCAF(DIEZ) ;
- ; for one compiled input template (DIEZ), delete its "AF" entries
- N %,X S X=""
- F S X=$O(^DIE("AF",X)) Q:X="" K:'X ^(X,DIEZ) S %=0 F S %=$O(^DIE("AF",X,%)) Q:%'>0 K:$D(^(%,DIEZ)) ^(DIEZ)
- Q
- ;
- UNC(DIEZ,DIFLAGS) ;
- ; DBS: silent entry point to uncompile an input template
- ; DIEZ = IEN of input template to uncompile
- ; DIFLAGS = flags:
- ; D = compiled routines are also deleted
- K ^DIE(DIEZ,"ROU")
- D UNCAF(DIEZ)
- I $G(DIFLAGS)["D" D
- . N DINAME S DINAME=$G(^DIE(DIEZ,"ROUOLD")) Q:DINAME=""
- . N DIROU,DISUF F DISUF="",1:1 D Q:DIROU=""
- . . S DIROU=DINAME_DISUF I '$$ROUEXIST^DILIBF(DIROU) S DIROU="" Q
- . . N X S X=DIROU X $G(^DD("OS",DISYS,"DEL"))
- Q
- ;
- ;
- DELETROU(DIEZNAME) ;DELETE THE ROUTINES NAMED 'DIEZNAME' CONCATENATED WITH NUMBER
- Q:DIEZNAME="" Q:$L($T(+2^@DIEZNAME),";")>2 ;TRY TO KEEP FROM BLOWING AWAY A REAL ROUTINE!
- N DIEZ,DIEZDEL,X,DIEZEXST,C
- S C=0,DIEZEXST="I $L($T(^@X))",DIEZDEL=$G(^DD("OS",DISYS,"DEL")) Q:DIEZDEL=""
- F DIEZ=1:1:1000 D Q:C>20 ;STOP IF THERE IS A GAP OF 20
- .S X=DIEZNAME_DIEZ X DIEZEXST I X DIEZDEL S C=0 Q
- .S C=C+1
- S X=DIEZNAME X DIEZEXST I X DIEZDEL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEZ 5735 printed Jan 18, 2025@03:48:25 Page 2
- DIEZ ;SFISC/GFT - COMPILE INPUT TEMPLATE ; Nov 30, 2012
- +1 ;;22.2;VA FileMan;**14,18**;Jan 05, 2016;Build 2
- +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 IF $GET(DUZ(0))'="@"
- if $DATA(^DI(.84,0))
- WRITE $CHAR(7),$$EZBLD^DIALOG(101)
- GOTO K
- EN1 if '$DATA(DISYS)
- DO OS^DII
- +1 IF '$DATA(^DD("OS",DISYS,"ZS"))
- WRITE $$EZBLD^DIALOG(820),$CHAR(7)
- GOTO K
- +2 SET U="^"
- if '$GET(DTIME)
- SET DTIME=300
- NEW L,DNM
- +3 DO SIZ^DIPZ0(8033)
- if $DATA(DTOUT)!($DATA(DUOUT))!('X)
- GOTO K
- SET DMAX=X
- if $DATA(DIX)
- QUIT
- TEM KILL DIC
- SET DIC="^DIE("
- SET DIC(0)="AEQ"
- SET DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,^(""ROU"")"
- SET DIC("S")="I Y'<1"
- DO ^DIC
- if '$DATA(^DIE(+Y,"DR"))
- GOTO K
- SET DIPZ=+Y
- +1 DO RNM^DIPZ0(8033)
- if $DATA(DTOUT)!($DATA(DUOUT))!(X="")
- GOTO K
- SET DNM=X
- KILL DIC
- +2 WRITE !
- SET DIR(0)="Y"
- SET DIR("A")=$$EZBLD^DIALOG(8020)
- DO ^DIR
- KILL DIR
- if 'Y!($DATA(DIRUT))
- GOTO K
- +3 SET X=DNM
- SET Y=DIPZ
- KILL DIPZ
- EN ; compile INPUT template
- +1 ;INPUT: X=name of routine for compiling, Y=ien of INPUT template
- +2 ;p18
- if '$DATA(DISYS)
- DO OS^DII
- +3 if '$GET(DIEZS)
- WRITE !
- KILL ^UTILITY($JOB),DRN
- +4 NEW L,DIEZQ,DIR
- SET DMAX=DMAX-2150
- SET DNM=X
- SET DIEZ=+Y
- SET DRN=""
- SET DRD=0
- SET DIEZQ=0
- +5 ;p14
- DO DT^DICRW
- DO DELETROU(DNM)
- SET X=-1
- +6 SET DP=$PIECE(^DIE(DIEZ,0),U,4)
- SET DIE=^DIC(DP,0,"GL")
- +7 IF '$DATA(^DIE(DIEZ,"DR",1,DP))
- SET ^DIE(DIEZ,"DR",1,DP)=^DIE(DIEZ,"DR")
- +8 ;D DT^DICRW S X=-1 ;p14 move this line before DELETROU to define DISYS
- +9 KILL T
- SET T(1)=$PIECE(^DIE(DIEZ,0),U)
- SET T(2)=$$EZBLD^DIALOG(8033)
- SET T(3)=DP
- DO BLD^DIALOG(8024,.T,"","DIR")
- if '$GET(DIEZS)
- WRITE !,DIR
- KILL T
- +10 DO UNCAF(DIEZ)
- +11 KILL DOV,^DIE(DIEZ,"RD"),DR
- SET DR=^("DR",1,DP)
- SET (DIER,DL)=1
- SET DIEZL=0
- SET DIEZAB=U
- +12 DO NEWROU
- FOR %=0:0
- SET %=$ORDER(^DIE(DIEZ,"DR",99,%))
- if %=""
- QUIT
- FOR %Y=0:0
- SET %Y=$ORDER(^DIE(DIEZ,"DR",99,%,%Y))
- if %Y=""
- QUIT
- SET F=0
- SET Q=^DIE(DIEZ,"DR",99,%,%Y)
- DO QFF^DIEZ2
- SET X=" S DR(99,"_%_","_%Y_")="_Q
- DO L^DIEZ2
- +13 SET X=" N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1(""DIEZ"")"
- DO L^DIEZ2
- +14 SET X=" M DIEZAR=^DIE("_DIEZ_",""AR"") S DICRREC=""TRIG^DIE17"""
- DO L^DIEZ2
- +15 NEW DIEZTMP
- SET DIEZTMP=$$GETTMP^DIKC1("DIEZ")
- +16 SET X=" S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_"","",DIEZ="_DIEZ_",U=""^"""
- GOTO ^DIEZ0
- +17 ;
- NEWROU ;
- +1 KILL ^UTILITY($JOB,0)
- SET DQ=0
- SET T=99
- SET L=3
- +2 SET ^UTILITY($JOB,0,1)=DNM_DRN_" ; "_$PIECE("GENERATED FROM '"_$PIECE(^DIE(DIEZ,0),U,1)_"' INPUT TEMPLATE(#"_DIEZ_"), FILE "_DP,U,DRN="")_";"_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
- +3 SET ^UTILITY($JOB,0,2)=" D DE G BEGIN"
- +4 SET ^UTILITY($JOB,0,3)="BEGIN S DNM="""_DNM_DRN_""",DQ=1"
- +5 IF '$DATA(DRN(+DRN))
- SET DRN(+DRN)=U
- +6 QUIT
- +7 ;
- EN2(Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZZMSG) ;Silent or Talking with parameter passing
- +1 ;and optionally return list of routines built and if successful
- +2 ;IEN,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY
- +3 ;Y=TEMPLATE IEN (required)
- +4 ;FLAGS="T"alk (optional)
- +5 ;X=ROUTINE NAME (required)
- +6 ;DMAX=ROUTINE SIZE (optional)
- +7 ;DIEZRLA=ROUTINE LIST ARRAY, by value (optional)
- +8 ;DIEZZMSG=MESSAGE ARRAY (optional) (default ^TMP)
- +9 ;*
- +10 ;DIEZS will be used to indicate "silent" if set to 1
- +11 ;Write statements are made conditional, if not "silent"
- +12 ;*
- +13 NEW DIEZS,DNM,DIQUIET,DIEZRIEN,DIEZRLAZ,DIEZRLAF
- +14 NEW DIK,DIC,%I,DICS
- +15 SET DIEZS=$GET(DIEZFLGS)'["T"
- +16 if DIEZS
- SET DIQUIET=1
- +17 IF '$DATA(DIFM)
- NEW DIFM
- SET DIFM=1
- Begin DoDot:1
- +18 NEW Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZS
- +19 DO INIZE^DIEFU
- End DoDot:1
- +20 IF $GET(Y)'>0
- DO BLD^DIALOG(1700,"IEN for Edit Template missing or invalid")
- GOTO EN2E
- +21 IF '$DATA(^DIE(Y,0))
- DO BLD^DIALOG(1700,"No Edit Template on file with IEN="_Y)
- GOTO EN2E
- +22 IF $GET(X)']""
- DO BLD^DIALOG(1700,"Routine name missing this Edit Template, IEN="_Y)
- GOTO EN2E
- +23 IF X'?1U.NU&(X'?1"%"1U.NU)
- DO BLD^DIALOG(1700,"Routine name invalid")
- GOTO EN2E
- +24 IF $LENGTH(X)>7
- DO BLD^DIALOG(1700,"Routine name too long")
- GOTO EN2E
- +25 SET DIEZRLA=$GET(DIEZRLA,"DIEZRLAZ")
- SET DIEZRIEN=Y
- +26 if DIEZRLA=""
- SET DIEZRLA="DIEZRLAZ"
- if $GET(DMAX)<2500!($GET(DMAX)>^DD("ROU"))
- SET DMAX=^DD("ROU")
- +27 SET DIEZRLAF=""
- +28 KILL @DIEZRLA
- +29 DO EN
- +30 if 'DIEZS!(DIEZRLAF)
- GOTO EN2E
- +31 DO BLD^DIALOG(1700,"Compiling Edit Template (IEN="_DIEZRIEN_")"_$SELECT(DIEZRLAF=0:", routine name too long",1:""))
- EN2E IF 'DIEZS
- DO MSG^DIALOG()
- QUIT
- +1 IF $GET(DIEZZMSG)]""
- DO CALLOUT^DIEFU(DIEZZMSG)
- +2 QUIT
- +3 ;
- RECOMP SET DIX=1
- DO DIEZ
- if '$DATA(DIX)
- QUIT
- NEW DIMAX
- SET DIMAX=DMAX
- +1 FOR DIX=0:0
- SET DIX=$ORDER(^DIE(DIX))
- if DIX'>0
- QUIT
- IF $DATA(^(DIX,0))
- IF $DATA(^("ROU"))
- SET %=$PIECE(^(0),"^",1)
- SET X=$EXTRACT(^("ROU"),2,99)
- IF X]""
- SET Y=DIX
- SET DMAX=DIMAX
- DO EN
- +2 ;
- K KILL %,DDH,DIC,DIX,DIPZ,DMAX,DNM,DTOUT,DIRUT,DIROUT,DUOUT,X,Y
- QUIT
- +1 ;DIALOG #101 'only those with programmer's access'
- +2 ; #820 'no way to save routines on the system'
- +3 ; #8020 'Should the compilation run now?'
- +4 ; #8024 'Compiling template name Input template of file n'
- +5 ; #8033 'Input template'
- UNCAF(DIEZ) ;
- +1 ; for one compiled input template (DIEZ), delete its "AF" entries
- +2 NEW %,X
- SET X=""
- +3 FOR
- SET X=$ORDER(^DIE("AF",X))
- if X=""
- QUIT
- if 'X
- KILL ^(X,DIEZ)
- SET %=0
- FOR
- SET %=$ORDER(^DIE("AF",X,%))
- if %'>0
- QUIT
- if $DATA(^(%,DIEZ))
- KILL ^(DIEZ)
- +4 QUIT
- +5 ;
- UNC(DIEZ,DIFLAGS) ;
- +1 ; DBS: silent entry point to uncompile an input template
- +2 ; DIEZ = IEN of input template to uncompile
- +3 ; DIFLAGS = flags:
- +4 ; D = compiled routines are also deleted
- +5 KILL ^DIE(DIEZ,"ROU")
- +6 DO UNCAF(DIEZ)
- +7 IF $GET(DIFLAGS)["D"
- Begin DoDot:1
- +8 NEW DINAME
- SET DINAME=$GET(^DIE(DIEZ,"ROUOLD"))
- if DINAME=""
- QUIT
- +9 NEW DIROU,DISUF
- FOR DISUF="",1:1
- Begin DoDot:2
- +10 SET DIROU=DINAME_DISUF
- IF '$$ROUEXIST^DILIBF(DIROU)
- SET DIROU=""
- QUIT
- +11 NEW X
- SET X=DIROU
- XECUTE $GET(^DD("OS",DISYS,"DEL"))
- End DoDot:2
- if DIROU=""
- QUIT
- End DoDot:1
- +12 QUIT
- +13 ;
- +14 ;
- DELETROU(DIEZNAME) ;DELETE THE ROUTINES NAMED 'DIEZNAME' CONCATENATED WITH NUMBER
- +1 ;TRY TO KEEP FROM BLOWING AWAY A REAL ROUTINE!
- if DIEZNAME=""
- QUIT
- if $LENGTH($TEXT(+2^@DIEZNAME),";")>2
- QUIT
- +2 NEW DIEZ,DIEZDEL,X,DIEZEXST,C
- +3 SET C=0
- SET DIEZEXST="I $L($T(^@X))"
- SET DIEZDEL=$GET(^DD("OS",DISYS,"DEL"))
- if DIEZDEL=""
- QUIT
- +4 ;STOP IF THERE IS A GAP OF 20
- FOR DIEZ=1:1:1000
- Begin DoDot:1
- +5 SET X=DIEZNAME_DIEZ
- XECUTE DIEZEXST
- IF $TEST
- XECUTE DIEZDEL
- SET C=0
- QUIT
- +6 SET C=C+1
- End DoDot:1
- if C>20
- QUIT
- +7 SET X=DIEZNAME
- XECUTE DIEZEXST
- IF $TEST
- XECUTE DIEZDEL
- +8 QUIT