INHDIPZ2 ;GFT; 22 Oct 91 05:33
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
F R=0:0 S R=$O(DXS(R)),W="" Q:'R K:$D(DXS(R))>9 ^DIPT(DIPZ,"DXS",R) F 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
I $D(^DIPT(DIPZ,"DXS")) S X=" D:$D(DXS)<9 ^"_DNM_"D" D L
DIL S DIL=$O(^UTILITY("DIPZ",$J,DIL)) G DHD:'DIL
S DHT=^(DIL) I DRN<DIPZLR,DIL>DRN(+DRN) D SV
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 SV
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+(DIPZTYPE="A"*2))!(%>239) S X=X_""""_$S(DIPZTYPE="R":",!!",1:",!") D L Q
END S:DIPZTYPE="A" IOM=IOM+2
D SV,DXS S DM=0,F=""
K K ^UTILITY($J),^("DIPZ",$J),DIPZL,DISMIN,%X,%Y,DG,DIL,DLN,DP,F,DL,DM,DMAX,DNM,DRD,DRJ,DIO,DX,DY,DRN,DIPZLR,V,R,W,Y,T
Q
;
SV F %=$S($D(DCL)>9:1,0'[DCL:7,1:11):1 S X=$T(@("TEXT"_$S(DIPZTYPE="R":"",1:"A"))+%) Q:$E(X,2,3)'=";;" S X=$E(X,4,999) D L
S X="DT S DY=Y "_^DD("DD") D L S X=" "_$S(DIPZTYPE="R":"W Y",1:"S @INV@(INL)=$G(@INV@(INL))_Y,INP=INP+$L(Y)")_" S Y=DY Q" D L S X=DNM_DRN X ^("OS",^DD("OS"),"ZS") W !,"'"_X_"' ROUTINE FILED"
S DRN=DRN+1
NEW K ^UTILITY($J,0) S L=0,X=DNM_DRN_" ; GENERATED FROM '"_$P(^DIPT(DIPZ,0),U)_"' PRINT TEMPLATE (#"_DIPZ_") ; "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
I DRN="" S X=X_" ; (FILE "_DP_", MARGIN="_IOM_")"
D L Q:DRN]""
S X=" K DUOUT" D L
Q:DIPZTYPE'="A"
S X=" S INP=0,INL=$G(INL)+1"
L S L=L+1,^UTILITY($J,0,L)=X Q
;
DXS ;Save code to build DXS array
Q:'$D(^DIPT(DIPZ,"DXS"))
N I,J,Z,L,S S Z=0 D DXSN
F I=0:0 S I=$O(^DIPT(DIPZ,"DXS",I)) Q:'I S J=$O(^(I,"")) F Q:J="" D
. S X=" S DXS("_$S(+I=I:I,1:""""_I_"""")_","_$S(+J=J:J,1:""""_J_"""")_")="""_$$REPLACE^UTIL(^(J),"""","""""")_"""",S=S+$L(X) I S>DMAX D
.. N X S X=" G ^"_DNM_$C(68+Z+1) D L S X=DNM_$C(68+Z) X ^DD("OS",^DD("OS"),"ZS") W !,"'",X,"' ROUTINE FILED" S Z=Z+1 D DXSN
. D L S J=$O(^DIPT(DIPZ,"DXS",I,J))
S X=" Q" D L S X=DNM_$C(68+Z) X ^DD("OS",^DD("OS"),"ZS") W !,"'",X,"' ROUTINE FILED"
Q
DXSN ;Start new DXS routine
S (S,L)=0 K ^UTILITY($J,0)
S X=DNM_$C(68+Z)_" ; GENERATED FROM '"_$P(^DIPT(DIPZ,0),U)_"' PRINT TEMPLATE (#"_DIPZ_") ; "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),S=S+$L(X) D L
S X=" ;Code to build the DXS array",S=S+$L(X) D L
I 'Z S X=" K DXS",S=S+$L(X) D L
;
TEXT ;
;; Q
;;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
;;DITTO(Y,C) ;
;;D I Y=DITTO(C) S Y="" Q
;; S DITTO(C)=Y
;; Q
;;N Q:$G(DUOUT) W !
;;T Q:$G(DUOUT) W:$X ! I $D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL D TOP^DIWW W:$X !
;; Q
;;M Q:$G(DUOUT) G @DIXX
TEXTA ;
;; Q
;;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
;;DITTO(Y,C) ;
;;D I Y=DITTO(C) S Y="" Q
;; S DITTO(C)=Y
;; Q
;;N S INL=INL+1,INP=0,@INV@(INL)=""
;;T S:INP INL=INL+1,INP=0,@INV@(INL)=""
;; Q
;;M G @DIXX
INHDIPZ2 ;GFT; 22 Oct 91 05:33
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+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
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
+5 IF $DATA(^DIPT(DIPZ,"DXS"))
SET X=" D:$D(DXS)<9 ^"_DNM_"D"
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 SV
+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 SV
+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+(DIPZTYPE="A"*2))!(%>239)
SET X=X_""""_$SELECT(DIPZTYPE="R":",!!",1:",!")
DO L
QUIT
END IF DIPZTYPE="A"
SET IOM=IOM+2
+1 DO SV
DO DXS
SET DM=0
SET F=""
K KILL ^UTILITY($JOB),^("DIPZ",$JOB),DIPZL,DISMIN,%X,%Y,DG,DIL,DLN,DP,F,DL,DM,DMAX,DNM,DRD,DRJ,DIO,DX,DY,DRN,DIPZLR,V,R,W,Y,T
+1 QUIT
+2 ;
SV FOR %=$SELECT($DATA(DCL)>9:1,0'[DCL:7,1:11):1
SET X=$TEXT(@("TEXT"_$SELECT(DIPZTYPE="R":"",1:"A"))+%)
IF $EXTRACT(X,2,3)'=";;"
QUIT
SET X=$EXTRACT(X,4,999)
DO L
+1 SET X="DT S DY=Y "_^DD("DD")
DO L
SET X=" "_$SELECT(DIPZTYPE="R":"W Y",1:"S @INV@(INL)=$G(@INV@(INL))_Y,INP=INP+$L(Y)")_" S Y=DY Q"
DO L
SET X=DNM_DRN
XECUTE ^("OS",^DD("OS"),"ZS")
WRITE !,"'"_X_"' ROUTINE FILED"
+2 SET DRN=DRN+1
NEW KILL ^UTILITY($JOB,0)
SET L=0
SET X=DNM_DRN_" ; GENERATED FROM '"_$PIECE(^DIPT(DIPZ,0),U)_"' PRINT TEMPLATE (#"_DIPZ_") ; "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+1 IF DRN=""
SET X=X_" ; (FILE "_DP_", MARGIN="_IOM_")"
+2 DO L
IF DRN]""
QUIT
+3 SET X=" K DUOUT"
DO L
+4 IF DIPZTYPE'="A"
QUIT
+5 SET X=" S INP=0,INL=$G(INL)+1"
L SET L=L+1
SET ^UTILITY($JOB,0,L)=X
QUIT
+1 ;
DXS ;Save code to build DXS array
+1 IF '$DATA(^DIPT(DIPZ,"DXS"))
QUIT
+2 NEW I,J,Z,L,S
SET Z=0
DO DXSN
+3 FOR I=0:0
SET I=$ORDER(^DIPT(DIPZ,"DXS",I))
IF 'I
QUIT
SET J=$ORDER(^(I,""))
FOR
IF J=""
QUIT
Begin DoDot:1
+4 SET X=" S DXS("_$SELECT(+I=I:I,1:""""_I_"""")_","_$SELECT(+J=J:J,1:""""_J_"""")_")="""_$$REPLACE^UTIL(^(J),"""","""""")_""""
SET S=S+$LENGTH(X)
IF S>DMAX
Begin DoDot:2
+5 NEW X
SET X=" G ^"_DNM_$CHAR(68+Z+1)
DO L
SET X=DNM_$CHAR(68+Z)
XECUTE ^DD("OS",^DD("OS"),"ZS")
WRITE !,"'",X,"' ROUTINE FILED"
SET Z=Z+1
DO DXSN
End DoDot:2
+6 DO L
SET J=$ORDER(^DIPT(DIPZ,"DXS",I,J))
End DoDot:1
+7 SET X=" Q"
DO L
SET X=DNM_$CHAR(68+Z)
XECUTE ^DD("OS",^DD("OS"),"ZS")
WRITE !,"'",X,"' ROUTINE FILED"
+8 QUIT
DXSN ;Start new DXS routine
+1 SET (S,L)=0
KILL ^UTILITY($JOB,0)
+2 SET X=DNM_$CHAR(68+Z)_" ; GENERATED FROM '"_$PIECE(^DIPT(DIPZ,0),U)_"' PRINT TEMPLATE (#"_DIPZ_") ; "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
SET S=S+$LENGTH(X)
DO L
+3 SET X=" ;Code to build the DXS array"
SET S=S+$LENGTH(X)
DO L
+4 IF 'Z
SET X=" K DXS"
SET S=S+$LENGTH(X)
DO L
+5 ;
TEXT ;
+1 ;; Q
+2 ;;CP G CP^DIO2
+3 ;;C S DQ(C)=Y
+4 ;;S S Q(C)=Y*Y+Q(C) S:L(C)>Y L(C)=Y S:H(C)<Y H(C)=Y
+5 ;;P S N(C)=N(C)+1
+6 ;;A S S(C)=S(C)+Y
+7 ;; Q
+8 ;;DITTO(Y,C) ;
+9 ;;D I Y=DITTO(C) S Y="" Q
+10 ;; S DITTO(C)=Y
+11 ;; Q
+12 ;;N Q:$G(DUOUT) W !
+13 ;;T Q:$G(DUOUT) W:$X ! I $D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL D TOP^DIWW W:$X !
+14 ;; Q
+15 ;;M Q:$G(DUOUT) G @DIXX
TEXTA ;
+1 ;; Q
+2 ;;CP G CP^DIO2
+3 ;;C S DQ(C)=Y
+4 ;;S S Q(C)=Y*Y+Q(C) S:L(C)>Y L(C)=Y S:H(C)<Y H(C)=Y
+5 ;;P S N(C)=N(C)+1
+6 ;;A S S(C)=S(C)+Y
+7 ;; Q
+8 ;;DITTO(Y,C) ;
+9 ;;D I Y=DITTO(C) S Y="" Q
+10 ;; S DITTO(C)=Y
+11 ;; Q
+12 ;;N S INL=INL+1,INP=0,@INV@(INL)=""
+13 ;;T S:INP INL=INL+1,INP=0,@INV@(INL)=""
+14 ;; Q
+15 ;;M G @DIXX
