DIPZ2 ;SFISC/GFT,XAK-COMPILE PRINT TEMPLATES ;09:33 PM 9 Feb 1999
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
F R=0:0 S R=$O(DXS(R)),W="" Q:'R K:$D(DXS(R))>9 ^DIPT(DIPZ,"DXS",R) F R=R:0 S W=$O(DXS(R,W)) Q:W="" S ^DIPT(DIPZ,"DXS",R,W)=DXS(R,W)
S DIPZLR=DRN,DRN="",DIL=0 D NEW
DXS I $D(^DIPT(DIPZ,"DXS")) S X=" I $D(DXS)<9 M DXS=^DIPT("_DIPZ_",""DXS"")" D L
S X=" S I(0)="""_$$CONVQQ^DILIBF(DK)_""",J(0)="_DP D L
DIL S DIL=$O(^UTILITY("DIPZ",$J,DIL)) G DHD:'DIL
S DHT=^(DIL) I DRN<DIPZLR,DIL>DRN(+DRN) D SAVE G:DIPZQ K
S X=DHT D L G DIL
;
DHD F F=2.9:0 S F=$O(^UTILITY($J,F)) Q:'F S DIL=$L(^(F))+DIL
I DIL+DIPZL>DMAX D SAVE G:DIPZQ K
S X=" Q" D L S X="HEAD ;" D L F F=2.9:0 S F=$O(^UTILITY($J,F)) Q:'F S X=" "_^(F) D L
S X=" W !,""" F %=1:1 S X=X_"-" I %=IOM!(%>239) S X=X_""",!!" D L Q
END D SAVE G:DIPZQ K
S ^DIPT(DIPZ,"ROUOLD")=DNM,^("IOM")=IOM,^("ROU")=U_DNM,^("LAST")=$S(DRN>1:DRN-1,1:""),DM=0,F=""
K ^("STATS"),DXS F DIP="L","H","DITTO","CP","Q","N","S" I $D(@DIP)>9 S %X=DIP_"(",%Y="^DIPT(DIPZ,""STATS"",DIP," D %XY^%RCR
F DIP=-1:0 S DIP=$O(^DIPT(DIPZ,"F",DIP)) Q:DIP="" S R=^(DIP) W:'$G(DIPZS) "." D R
K K ^UTILITY($J),^("DIPZ",$J),DIPZL,DISMIN,%X,%Y,DG,DIL,DLN,DL,DM,DMAX,DNM,DRD,DRJ,DIO,DX,DY,DRN,DIPZLR,V,R,W,Y,T,DIDXS,DINC
Q
;
R Q:R="" S W=$P(R,$C(126),1),R=$P(R,$C(126),2,999)
DM I DM G UP:$P(W,F,1)]"" S W=$P(W,F,2,999)
I 'W S:W?1"0".E ^DIPT("AF",DP,.001,DIPZ)="" G R
I $P(W,";",1)=+W S ^DIPT("AF",DP,+W,DIPZ)="" G R
G R:W'?.NP1",".E I W<0 S X=-W G DOWN
G R:'$D(^DD(DP,+W,0)) S X=+$P(^(0),U,2) G R:'X
DOWN S DM=DM+1,DP(DM)=DP,DP=X,F=F_+W_C G DM
UP S DP=DP(DM),DM=DM-1,F=$P(F,C,1,DM)_$E(C,DM>0) G DM
;
SAVE ;
S L=1.001,DINC=.001 S X=" G BEGIN" D L,OS^DII:'$D(DISYS) F %=$S($D(DCL)>9:1,0'[DCL:7,1:10):1 S X=$E($T(TEXT+%),4,999) Q:X="" D L
I $L(DNM_DRN)>8 S DIPZQ=1 W:'$G(DIPZS) $C(7),!,DNM_DRN_$$EZBLD^DIALOG(1503) S:$G(DIPZRLA)]"" DIPZRLAF=0 Q
S X=DNM_DRN X ^DD("OS",DISYS,"ZS") S %(1)=X D BLD^DIALOG(8025,.%,"","DIR") W:'$G(DIPZS) !,DIR K %,DIR S:$G(DIPZRLA)]"" @DIPZRLA@(DNM_DRN)="",DIPZRLAF=1
S DRN=DRN+1
NEW K ^UTILITY($J,0) S X=DNM_DRN_" ; GENERATED FROM '"_$P(^DIPT(DIPZ,0),U,1)_"' PRINT TEMPLATE (#"_DIPZ_") ; "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
S X=X_" ; ("_$S(DRN="":"FILE "_DP_", MARGIN="_IOM_")",1:"continued)"),L=1,DINC=1,^UTILITY($J,0,L)=X
S X=" S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT)"
L S L=L+DINC,^UTILITY($J,0,L)=X Q
;
;DIALOG #1503 'routine name is too long. Compilation...aborted'
; #8025 '...routine filed.'
;
TEXT ;
;;CP G CP^DIO2
;;C S DQ(C)=Y
;;S S Q(C)=Y*Y+Q(C) S:L(C)>Y L(C)=Y S:H(C)<Y H(C)=Y
;;P S N(C)=N(C)+1
;;A S S(C)=S(C)+Y
;; Q
;;D I Y=DITTO(C) S Y="" Q
;; S DITTO(C)=Y
;; Q
;;N W !
;;T W:$X ! I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1)
;; S DISTP=DISTP+1,DILCT=DILCT+1 D:'(DISTP#100) CSTP^DIO2
;; Q
;;DT I $G(DUZ("LANG"))>1,Y W $$OUT^DIALOGU(Y,"DD") Q
;; I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
;; W Y Q
;;M D @DIXX
;; Q
;;BEGIN ;
DIPZ2 ;SFISC/GFT,XAK-COMPILE PRINT TEMPLATES ;09:33 PM 9 Feb 1999
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 FOR R=0:0
SET R=$ORDER(DXS(R))
SET W=""
IF 'R
QUIT
IF $DATA(DXS(R))>9
KILL ^DIPT(DIPZ,"DXS",R)
FOR R=R:0
SET W=$ORDER(DXS(R,W))
IF W=""
QUIT
SET ^DIPT(DIPZ,"DXS",R,W)=DXS(R,W)
+4 SET DIPZLR=DRN
SET DRN=""
SET DIL=0
DO NEW
DXS IF $DATA(^DIPT(DIPZ,"DXS"))
SET X=" I $D(DXS)<9 M DXS=^DIPT("_DIPZ_",""DXS"")"
DO L
+1 SET X=" S I(0)="""_$$CONVQQ^DILIBF(DK)_""",J(0)="_DP
DO L
DIL SET DIL=$ORDER(^UTILITY("DIPZ",$JOB,DIL))
IF 'DIL
GOTO DHD
+1 SET DHT=^(DIL)
IF DRN<DIPZLR
IF DIL>DRN(+DRN)
DO SAVE
IF DIPZQ
GOTO K
+2 SET X=DHT
DO L
GOTO DIL
+3 ;
DHD FOR F=2.9:0
SET F=$ORDER(^UTILITY($JOB,F))
IF 'F
QUIT
SET DIL=$LENGTH(^(F))+DIL
+1 IF DIL+DIPZL>DMAX
DO SAVE
IF DIPZQ
GOTO K
+2 SET X=" Q"
DO L
SET X="HEAD ;"
DO L
FOR F=2.9:0
SET F=$ORDER(^UTILITY($JOB,F))
IF 'F
QUIT
SET X=" "_^(F)
DO L
+3 SET X=" W !,"""
FOR %=1:1
SET X=X_"-"
IF %=IOM!(%>239)
SET X=X_""",!!"
DO L
QUIT
END DO SAVE
IF DIPZQ
GOTO K
+1 SET ^DIPT(DIPZ,"ROUOLD")=DNM
SET ^("IOM")=IOM
SET ^("ROU")=U_DNM
SET ^("LAST")=$SELECT(DRN>1:DRN-1,1:"")
SET DM=0
SET F=""
+2 KILL ^("STATS"),DXS
FOR DIP="L","H","DITTO","CP","Q","N","S"
IF $DATA(@DIP)>9
SET %X=DIP_"("
SET %Y="^DIPT(DIPZ,""STATS"",DIP,"
DO %XY^%RCR
+3 FOR DIP=-1:0
SET DIP=$ORDER(^DIPT(DIPZ,"F",DIP))
IF DIP=""
QUIT
SET R=^(DIP)
IF '$GET(DIPZS)
WRITE "."
DO R
K KILL ^UTILITY($JOB),^("DIPZ",$JOB),DIPZL,DISMIN,%X,%Y,DG,DIL,DLN,DL,DM,DMAX,DNM,DRD,DRJ,DIO,DX,DY,DRN,DIPZLR,V,R,W,Y,T,DIDXS,DINC
+1 QUIT
+2 ;
R IF R=""
QUIT
SET W=$PIECE(R,$CHAR(126),1)
SET R=$PIECE(R,$CHAR(126),2,999)
DM IF DM
IF $PIECE(W,F,1)]""
GOTO UP
SET W=$PIECE(W,F,2,999)
+1 IF 'W
IF W?1"0".E
SET ^DIPT("AF",DP,.001,DIPZ)=""
GOTO R
+2 IF $PIECE(W,";",1)=+W
SET ^DIPT("AF",DP,+W,DIPZ)=""
GOTO R
+3 IF W'?.NP1",".E
GOTO R
IF W<0
SET X=-W
GOTO DOWN
+4 IF '$DATA(^DD(DP,+W,0))
GOTO R
SET X=+$PIECE(^(0),U,2)
IF 'X
GOTO R
DOWN SET DM=DM+1
SET DP(DM)=DP
SET DP=X
SET F=F_+W_C
GOTO DM
UP SET DP=DP(DM)
SET DM=DM-1
SET F=$PIECE(F,C,1,DM)_$EXTRACT(C,DM>0)
GOTO DM
+1 ;
SAVE ;
+1 SET L=1.001
SET DINC=.001
SET X=" G BEGIN"
DO L
IF '$DATA(DISYS)
DO OS^DII
FOR %=$SELECT($DATA(DCL)>9:1,0'[DCL:7,1:10):1
SET X=$EXTRACT($TEXT(TEXT+%),4,999)
IF X=""
QUIT
DO L
+2 IF $LENGTH(DNM_DRN)>8
SET DIPZQ=1
IF '$GET(DIPZS)
WRITE $CHAR(7),!,DNM_DRN_$$EZBLD^DIALOG(1503)
IF $GET(DIPZRLA)]""
SET DIPZRLAF=0
QUIT
+3 SET X=DNM_DRN
XECUTE ^DD("OS",DISYS,"ZS")
SET %(1)=X
DO BLD^DIALOG(8025,.%,"","DIR")
IF '$GET(DIPZS)
WRITE !,DIR
KILL %,DIR
IF $GET(DIPZRLA)]""
SET @DIPZRLA@(DNM_DRN)=""
SET DIPZRLAF=1
+4 SET DRN=DRN+1
NEW KILL ^UTILITY($JOB,0)
SET X=DNM_DRN_" ; GENERATED FROM '"_$PIECE(^DIPT(DIPZ,0),U,1)_"' PRINT TEMPLATE (#"_DIPZ_") ; "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+1 SET X=X_" ; ("_$SELECT(DRN="":"FILE "_DP_", MARGIN="_IOM_")",1:"continued)")
SET L=1
SET DINC=1
SET ^UTILITY($JOB,0,L)=X
+2 SET X=" S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT)"
L SET L=L+DINC
SET ^UTILITY($JOB,0,L)=X
QUIT
+1 ;
+2 ;DIALOG #1503 'routine name is too long. Compilation...aborted'
+3 ; #8025 '...routine filed.'
+4 ;
TEXT ;
+1 ;;CP G CP^DIO2
+2 ;;C S DQ(C)=Y
+3 ;;S S Q(C)=Y*Y+Q(C) S:L(C)>Y L(C)=Y S:H(C)<Y H(C)=Y
+4 ;;P S N(C)=N(C)+1
+5 ;;A S S(C)=S(C)+Y
+6 ;; Q
+7 ;;D I Y=DITTO(C) S Y="" Q
+8 ;; S DITTO(C)=Y
+9 ;; Q
+10 ;;N W !
+11 ;;T W:$X ! I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1)
+12 ;; S DISTP=DISTP+1,DILCT=DILCT+1 D:'(DISTP#100) CSTP^DIO2
+13 ;; Q
+14 ;;DT I $G(DUZ("LANG"))>1,Y W $$OUT^DIALOGU(Y,"DD") Q
+15 ;; I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
+16 ;; W Y Q
+17 ;;M D @DIXX
+18 ;; Q
+19 ;;BEGIN ;
