- 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
