DIPZ2 ;SFISC/GFT,XAK-COMPILE PRINT TEMPLATES ;07:33 PM 16 Dec 1999
;;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.
;
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
EGP S ^DIPT(DIPZ,"ROUOLD")=DNM,^("IOM")=IOM,^("ROU")=U_DNM,^("LAST")=$S(DRN>1:DRN-1,1:""),DM=0,F="" I $G(DUZ("LANG")) S ^("ROULANG")=DUZ("LANG") ;**CCO/NI REMEMBER LANGUAGE
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.'
;**CCO/NI TAG 'TEXT+15' CHANGED FOR DATE OUTPUT
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
;; X ^DD("DD")
;; W Y Q
;;M D @DIXX
;; Q
;;BEGIN ;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIPZ2 3463 printed Nov 22, 2024@18:03:28 Page 2
DIPZ2 ;SFISC/GFT,XAK-COMPILE PRINT TEMPLATES ;07:33 PM 16 Dec 1999
+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 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)
+8 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
EGP ;**CCO/NI REMEMBER LANGUAGE
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=""
IF $GET(DUZ("LANG"))
SET ^("ROULANG")=DUZ("LANG")
+1 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
+2 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 ;**CCO/NI TAG 'TEXT+15' CHANGED FOR DATE OUTPUT
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 ;; X ^DD("DD")
+16 ;; W Y Q
+17 ;;M D @DIXX
+18 ;; Q
+19 ;;BEGIN ;
