- 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 ;
