- DIPZ ;SFISC/XAK,TKW-COMPILE PRINT TEMPLATES ;3FEB2011
- ;;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.
- ;
- I $G(DUZ(0))'="@" W:$D(^DI(.84,0)) $C(7),$$EZBLD^DIALOG(101) Q
- EN1 N DNM,X,Y,Z D K I '$D(DISYS) N DISYS D OS^DII
- I '$D(^DD("OS",DISYS,"ZS")) W $C(7),$$EZBLD^DIALOG(820) Q
- S DTIME=$S('$D(DTIME):300,1:DTIME)
- D SIZ^DIPZ0(8034) G:$D(DTOUT)!$D(DUOUT)!'X K S DMAX=X
- TEM K DIC S DIC="^DIPT(",DIC(0)="AIEQ"
- S DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,^(""ROU"")"
- S DIC("S")="I $D(^(""F""))>9,'$P(^(0),U,8),Y'<1" D ^DIC G K:Y<0
- S DIPZ=+Y
- D RNM^DIPZ0(8034) G:$D(DTOUT)!($D(DUOUT))!(X="") K S DNM=X K DIC
- IOM K DIR S DIR("B")=$G(^DIPT(DIPZ,"IOM")) K:'DIR("B") DIR
- S DIR(0)="N^19:255",DIR("A")=$$EZBLD^DIALOG(8022) D BLD^DIALOG(8023,"","","DIR(""?"")")
- D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT))!'X K S IOM=X
- W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G K:'Y!($D(DIRUT))
- S X=DNM,Y=DIPZ D ENZ
- K K DMAX,DIC,DCL,R,M,DE,DI,DPP,DIPZ,DHD,DIWL,DIWR,DK,DP,DNP,DCL,DITTO,DUOUT,DIRUT,DIROUT,DTOUT
- K %,%H,I,O,C,D,DD,DHT,DIL0,DIP,DN,DU,F,H,L,N,S,Q,CP,DINC Q
- ;
- EN ;
- Q:'$D(^DIPT(Y,"IOM"))!($P($G(^DIPT(Y,0)),U,8)) S IOM=^("IOM") D ENZ G K
- ;
- ENZ S (R,DCL,DPP)=0 F %=0:0 S R=$O(^DIPT(+Y,"DCL",R)) Q:R="" F %=1:1 Q:%>$L(^(R)) S Z=$E(^(R),%) I Z?1P S DCL(R)=$G(DCL(R))_Z
- ENDIP ;
- W:'$G(DIPZS) ! K ^UTILITY($J),^("DIL",$J),^UTILITY("DIPZ",$J),DIPZ,DNP,DIPZLR,DRN,DIPZL,DX,DXS,R N DIPZQ S DIPZQ=0 D DELETROU^DIEZ(X)
- S DNM=X,DIPZ=+Y,DRD=0,DP=$P(^DIPT(DIPZ,0),U,4),DHD=$S(^("H")="@":"@",1:3) S:$D(^("DNP")) DNP=1
- S DK=^DIC(DP,0,"GL"),DMAX=DMAX-$S($D(DCL)>9:1600,1:1300),DRN=0,R="",L=0,DINC=1
- I '$D(@(DK_"0)")) Q ;THE DATA FILE MAY BE GONE
- I '$D(IOM) Q:$D(^DIPT(DIPZ,"IOM"))[0 S IOM=^("IOM")
- AF D DT^DICRW,INIT^DIP5 S X=-1
- S T(1)=$P(^DIPT(DIPZ,0),U),T(2)=$$EZBLD^DIALOG(8034),T(3)=DP D BLD^DIALOG(8024,.T,"","DIR")
- W:'$G(DIPZS) !,DIR K DIR
- F T=0:0 S X=$O(^DIPT("AF",X)) Q:X="" F %=0:0 S %=$O(^DIPT("AF",X,%)) Q:'% K:$D(^(%,DIPZ)) ^(DIPZ)
- F C=1:1 Q:'$D(^DIPT(DIPZ,"DXS",C,9.2))&'$D(^(9)) D DXS S:DIDXS DXS(C)=""
- S DL=1,DIPZL=0,DHT=-1,C=",",Q="""",^UTILITY($J,1)=""
- F DIP=-1:0 S DIP=$O(^DIPT(DIPZ,"F",DIP)) Q:DIP="" S R=^(DIP) D ^DIL
- D UNSTACK^DIL:DM,A^DIL,T^DIL2 K ^DIPT(DIPZ,"T") F R=-1:0 S R=$O(^UTILITY($J,"T",R)) Q:R="" S ^DIPT(DIPZ,"T",R)=^(R)
- S DX=DX+999,Y=$P(" D ^DIWW",1,''$D(DIWR))_" K Y" I DIWL S Y=Y_" K DIWF" S:DIWL=1 ^UTILITY("DIPZ",$J,.5)=" S DIWF=""W"""
- D PX^DIPZ1 G ^DIPZ2
- DXS S DIDXS=1
- I $D(^DIPT(DIPZ,"DXS",C,9)) S X=^(9) D ^DIM I '$D(X) S DIDXS=0
- Q
- ;
- EN2(Y,DIPZFLGS,X,DMAX,DIPZRLA,DIPZZMSG) ;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)
- ;DIPZRLA=ROUTINE LIST ARRAY, by value (optional)
- ;DIPZZMSG=MESSAGE ARRAY (optional) (default ^TMP)
- ;*
- ;DIPZS will be used to indicate "silent" if set to 1
- ;Write statements are made conditional, if not "silent"
- ;*
- N DIPZS,DNM,DIQUIET,DIPZRIEN,DIPZRLAZ,Z,DIPZRLAF
- N DIK,DIC,%I,DICS
- S DIPZS=$G(DIPZFLGS)'["T"
- S:DIPZS DIQUIET=1
- I '$D(DIFM) N DIFM S DIFM=1 D
- .N Y,DIPZFLGS,X,DMAX,DIPZRLA,DIPZS
- .D INIZE^DIEFU
- I $G(Y)'>0 D BLD^DIALOG(1700,"IEN for Print Template missing or invalid") G EN2E
- I '$D(^DIPT(Y,0)) D BLD^DIALOG(1700,"No Print Template on file with IEN="_Y) G EN2E
- I $G(^DIPT(Y,"IOM"))'>0 D BLD^DIALOG(1700,"No Margin Width for Print Template, IEN="_Y) G EN2E
- I $P($G(^DIPT(Y,0)),"^",8) D BLD^DIALOG(1700,"Print Template Invalid, IEN="_Y) G EN2E
- I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing this Print 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 DIPZRLA=$G(DIPZRLA,"DIPZRLAZ"),DIPZRIEN=Y
- S:DIPZRLA="" DIPZRLA="DIPZRLAZ" S:$G(DMAX)'>0!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU")
- S DIPZRLAF=""
- K @DIPZRLA
- D EN
- G:'DIPZS!(DIPZRLAF) EN2E
- D BLD^DIALOG(1700,"Compiling Print Template (IEN="_DIPZRIEN_")"_$S(DIPZRLAF=0:", routine name too long",1:""))
- EN2E I 'DIPZS D MSG^DIALOG() Q
- I $G(DIPZZMSG)]"" D CALLOUT^DIEFU(DIPZZMSG)
- Q
- ;
- ;DIALOG #101 'only those with programmer's access'
- ; #820 'no way to save routines on the system'
- ; #8020 'Should the compilation run now?'
- ; #8022 'Margin Width for output.'
- ; #8023 'Type a number from 19 to 255. This is the number...'
- ; #8024 'Compiling template name Print template of file n'
- ; #8034 'Print template'
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIPZ 4930 printed Feb 19, 2025@00:19:43 Page 2
- DIPZ ;SFISC/XAK,TKW-COMPILE PRINT TEMPLATES ;3FEB2011
- +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 IF $GET(DUZ(0))'="@"
- if $DATA(^DI(.84,0))
- WRITE $CHAR(7),$$EZBLD^DIALOG(101)
- QUIT
- EN1 NEW DNM,X,Y,Z
- DO K
- IF '$DATA(DISYS)
- NEW DISYS
- DO OS^DII
- +1 IF '$DATA(^DD("OS",DISYS,"ZS"))
- WRITE $CHAR(7),$$EZBLD^DIALOG(820)
- QUIT
- +2 SET DTIME=$SELECT('$DATA(DTIME):300,1:DTIME)
- +3 DO SIZ^DIPZ0(8034)
- if $DATA(DTOUT)!$DATA(DUOUT)!'X
- GOTO K
- SET DMAX=X
- TEM KILL DIC
- SET DIC="^DIPT("
- SET DIC(0)="AIEQ"
- +1 SET DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,^(""ROU"")"
- +2 SET DIC("S")="I $D(^(""F""))>9,'$P(^(0),U,8),Y'<1"
- DO ^DIC
- if Y<0
- GOTO K
- +3 SET DIPZ=+Y
- +4 DO RNM^DIPZ0(8034)
- if $DATA(DTOUT)!($DATA(DUOUT))!(X="")
- GOTO K
- SET DNM=X
- KILL DIC
- IOM KILL DIR
- SET DIR("B")=$GET(^DIPT(DIPZ,"IOM"))
- if 'DIR("B")
- KILL DIR
- +1 SET DIR(0)="N^19:255"
- SET DIR("A")=$$EZBLD^DIALOG(8022)
- DO BLD^DIALOG(8023,"","","DIR(""?"")")
- +2 DO ^DIR
- KILL DIR
- if $DATA(DTOUT)!($DATA(DUOUT))!'X
- GOTO K
- SET IOM=X
- +3 WRITE !
- SET DIR(0)="Y"
- SET DIR("A")=$$EZBLD^DIALOG(8020)
- DO ^DIR
- KILL DIR
- if 'Y!($DATA(DIRUT))
- GOTO K
- +4 SET X=DNM
- SET Y=DIPZ
- DO ENZ
- K KILL DMAX,DIC,DCL,R,M,DE,DI,DPP,DIPZ,DHD,DIWL,DIWR,DK,DP,DNP,DCL,DITTO,DUOUT,DIRUT,DIROUT,DTOUT
- +1 KILL %,%H,I,O,C,D,DD,DHT,DIL0,DIP,DN,DU,F,H,L,N,S,Q,CP,DINC
- QUIT
- +2 ;
- EN ;
- +1 if '$DATA(^DIPT(Y,"IOM"))!($PIECE($GET(^DIPT(Y,0)),U,8))
- QUIT
- SET IOM=^("IOM")
- DO ENZ
- GOTO K
- +2 ;
- ENZ SET (R,DCL,DPP)=0
- FOR %=0:0
- SET R=$ORDER(^DIPT(+Y,"DCL",R))
- if R=""
- QUIT
- FOR %=1:1
- if %>$LENGTH(^(R))
- QUIT
- SET Z=$EXTRACT(^(R),%)
- IF Z?1P
- SET DCL(R)=$GET(DCL(R))_Z
- ENDIP ;
- +1 if '$GET(DIPZS)
- WRITE !
- KILL ^UTILITY($JOB),^("DIL",$JOB),^UTILITY("DIPZ",$JOB),DIPZ,DNP,DIPZLR,DRN,DIPZL,DX,DXS,R
- NEW DIPZQ
- SET DIPZQ=0
- DO DELETROU^DIEZ(X)
- +2 SET DNM=X
- SET DIPZ=+Y
- SET DRD=0
- SET DP=$PIECE(^DIPT(DIPZ,0),U,4)
- SET DHD=$SELECT(^("H")="@":"@",1:3)
- if $DATA(^("DNP"))
- SET DNP=1
- +3 SET DK=^DIC(DP,0,"GL")
- SET DMAX=DMAX-$SELECT($DATA(DCL)>9:1600,1:1300)
- SET DRN=0
- SET R=""
- SET L=0
- SET DINC=1
- +4 ;THE DATA FILE MAY BE GONE
- IF '$DATA(@(DK_"0)"))
- QUIT
- +5 IF '$DATA(IOM)
- if $DATA(^DIPT(DIPZ,"IOM"))[0
- QUIT
- SET IOM=^("IOM")
- AF DO DT^DICRW
- DO INIT^DIP5
- SET X=-1
- +1 SET T(1)=$PIECE(^DIPT(DIPZ,0),U)
- SET T(2)=$$EZBLD^DIALOG(8034)
- SET T(3)=DP
- DO BLD^DIALOG(8024,.T,"","DIR")
- +2 if '$GET(DIPZS)
- WRITE !,DIR
- KILL DIR
- +3 FOR T=0:0
- SET X=$ORDER(^DIPT("AF",X))
- if X=""
- QUIT
- FOR %=0:0
- SET %=$ORDER(^DIPT("AF",X,%))
- if '%
- QUIT
- if $DATA(^(%,DIPZ))
- KILL ^(DIPZ)
- +4 FOR C=1:1
- if '$DATA(^DIPT(DIPZ,"DXS",C,9.2))&'$DATA(^(9))
- QUIT
- DO DXS
- if DIDXS
- SET DXS(C)=""
- +5 SET DL=1
- SET DIPZL=0
- SET DHT=-1
- SET C=","
- SET Q=""""
- SET ^UTILITY($JOB,1)=""
- +6 FOR DIP=-1:0
- SET DIP=$ORDER(^DIPT(DIPZ,"F",DIP))
- if DIP=""
- QUIT
- SET R=^(DIP)
- DO ^DIL
- +7 if DM
- DO UNSTACK^DIL
- DO A^DIL
- DO T^DIL2
- KILL ^DIPT(DIPZ,"T")
- FOR R=-1:0
- SET R=$ORDER(^UTILITY($JOB,"T",R))
- if R=""
- QUIT
- SET ^DIPT(DIPZ,"T",R)=^(R)
- +8 SET DX=DX+999
- SET Y=$PIECE(" D ^DIWW",1,''$DATA(DIWR))_" K Y"
- IF DIWL
- SET Y=Y_" K DIWF"
- if DIWL=1
- SET ^UTILITY("DIPZ",$JOB,.5)=" S DIWF=""W"""
- +9 DO PX^DIPZ1
- GOTO ^DIPZ2
- DXS SET DIDXS=1
- +1 IF $DATA(^DIPT(DIPZ,"DXS",C,9))
- SET X=^(9)
- DO ^DIM
- IF '$DATA(X)
- SET DIDXS=0
- +2 QUIT
- +3 ;
- EN2(Y,DIPZFLGS,X,DMAX,DIPZRLA,DIPZZMSG) ;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 ;DIPZRLA=ROUTINE LIST ARRAY, by value (optional)
- +8 ;DIPZZMSG=MESSAGE ARRAY (optional) (default ^TMP)
- +9 ;*
- +10 ;DIPZS will be used to indicate "silent" if set to 1
- +11 ;Write statements are made conditional, if not "silent"
- +12 ;*
- +13 NEW DIPZS,DNM,DIQUIET,DIPZRIEN,DIPZRLAZ,Z,DIPZRLAF
- +14 NEW DIK,DIC,%I,DICS
- +15 SET DIPZS=$GET(DIPZFLGS)'["T"
- +16 if DIPZS
- SET DIQUIET=1
- +17 IF '$DATA(DIFM)
- NEW DIFM
- SET DIFM=1
- Begin DoDot:1
- +18 NEW Y,DIPZFLGS,X,DMAX,DIPZRLA,DIPZS
- +19 DO INIZE^DIEFU
- End DoDot:1
- +20 IF $GET(Y)'>0
- DO BLD^DIALOG(1700,"IEN for Print Template missing or invalid")
- GOTO EN2E
- +21 IF '$DATA(^DIPT(Y,0))
- DO BLD^DIALOG(1700,"No Print Template on file with IEN="_Y)
- GOTO EN2E
- +22 IF $GET(^DIPT(Y,"IOM"))'>0
- DO BLD^DIALOG(1700,"No Margin Width for Print Template, IEN="_Y)
- GOTO EN2E
- +23 IF $PIECE($GET(^DIPT(Y,0)),"^",8)
- DO BLD^DIALOG(1700,"Print Template Invalid, IEN="_Y)
- GOTO EN2E
- +24 IF $GET(X)']""
- DO BLD^DIALOG(1700,"Routine name missing this Print Template, IEN="_Y)
- GOTO EN2E
- +25 IF X'?1U.NU&(X'?1"%"1U.NU)
- DO BLD^DIALOG(1700,"Routine name invalid")
- GOTO EN2E
- +26 IF $LENGTH(X)>7
- DO BLD^DIALOG(1700,"Routine name too long")
- GOTO EN2E
- +27 SET DIPZRLA=$GET(DIPZRLA,"DIPZRLAZ")
- SET DIPZRIEN=Y
- +28 if DIPZRLA=""
- SET DIPZRLA="DIPZRLAZ"
- if $GET(DMAX)'>0!($GET(DMAX)>^DD("ROU"))
- SET DMAX=^DD("ROU")
- +29 SET DIPZRLAF=""
- +30 KILL @DIPZRLA
- +31 DO EN
- +32 if 'DIPZS!(DIPZRLAF)
- GOTO EN2E
- +33 DO BLD^DIALOG(1700,"Compiling Print Template (IEN="_DIPZRIEN_")"_$SELECT(DIPZRLAF=0:", routine name too long",1:""))
- EN2E IF 'DIPZS
- DO MSG^DIALOG()
- QUIT
- +1 IF $GET(DIPZZMSG)]""
- DO CALLOUT^DIEFU(DIPZZMSG)
- +2 QUIT
- +3 ;
- +4 ;DIALOG #101 'only those with programmer's access'
- +5 ; #820 'no way to save routines on the system'
- +6 ; #8020 'Should the compilation run now?'
- +7 ; #8022 'Margin Width for output.'
- +8 ; #8023 'Type a number from 19 to 255. This is the number...'
- +9 ; #8024 'Compiling template name Print template of file n'
- +10 ; #8034 'Print template'