INHDIPZ.m

INHDIPZ(DIPZ,DNM,DMAX) ;GFT,JSH; 11 Feb 93 12:17;Script compiler - compile print template 

 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 ;COPYRIGHT 1991-2000 SAIC

 ;

 ;Paramaters:    DIPZ= template entry #

 ;               DNM = base routine name

 ;               DMAX= max routine size

 ;

 S IOM=258

 N DIC,DCL,R,M,DE,DI,DPP,DHD,DIWL,DIWR,DK,DP,DNP,DCL,DITTO,H,L,N,S,Q,CP,DIPZTYPE,IOM

 ;

ENZ S (R,DCL,DPP)=0 F  S R=$O(^DIPT(DIPZ,"DCL",R)) Q:R=""  F %=1:1 Q:%>$L(^(R))  S Z=$E(^(R),%) I Z?1P S DCL(R)=$G(DCL(R))_Z

ENDIP ;

 K ^UTILITY($J),^UTILITY("DIL",$J),^UTILITY("DIPZ",$J),DNP,DIPNCH,DIPZLR,DRN,DIPZL,DX,DXS

 S DIPZTYPE="A"

 S DRD=0,DP=$P(^DIPT(DIPZ,0),U,4),DHD="@" S:$D(^("DNP")) DNP=1 G K^INHDIPZ2:'$D(^DIC(DP,0,"GL")) S DK=^("GL"),DRN=0,R="",L=0

AF D INIT^DIP5 S X=-1 F  S X=$O(^DIPT("AF",X)) Q:X=""  F %=0:0 S %=$O(^DIPT("AF",X,%)) Q:%'>0  K:$D(^(%,DIPZ)) ^(DIPZ)

 F C=1:1 Q:'$D(^DIPT(DIPZ,"DXS",C,9.2))&'$D(^(9))  S DXS(C)=""

 S IOSL=9999,DL=1,DIPZL=0,DHT=-1,C=",",Q="""",^UTILITY($J,1)=""

 F DIP=-1:0 S DIP=$O(^DIPT(DIPZ,"F",DIP)) Q:DIP=""  S R=^(DIP) D ^DIL

 D UNSTACK^DIL:DM,A^DIL,T^DIL2 K ^DIPT(DIPZ,"T") F R=-1:0 S R=$O(^UTILITY($J,"T",R)) Q:R=""  S ^DIPT(DIPZ,"T",R)=^(R)

 S DX=DX+999,Y=$P(" D ^DIWWA",1,''$D(DIWR))_" K Y" I DIWL S Y=Y_",DIWF" S:DIWL=1 ^UTILITY("DIPZ",$J,.5)=" S DIWF=""W"""

 D PX^DIPZ1 G ^INHDIPZ2

 ;

INHDIPZ(DIPZ,DNM,DMAX) ;GFT,JSH; 11 Feb 93 12:17;Script compiler - compile print template 

 +1       ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 +2       ;COPYRIGHT 1991-2000 SAIC

 +3       ;

 +4       ;Paramaters:    DIPZ= template entry #

 +5       ;               DNM = base routine name

 +6       ;               DMAX= max routine size

 +7       ;

 +8        SET IOM=258

 +9        NEW DIC,DCL,R,M,DE,DI,DPP,DHD,DIWL,DIWR,DK,DP,DNP,DCL,DITTO,H,L,N,S,Q,CP,DIPZTYPE,IOM

 +10      ;

ENZ        SET (R,DCL,DPP)=0

           FOR 

               SET R=$ORDER(^DIPT(DIPZ,"DCL",R))

               IF R=""

                   QUIT 

               FOR %=1:1

                   IF %>$LENGTH(^(R))

                       QUIT 

                   SET Z=$EXTRACT(^(R),%)

                   IF Z?1P

                       SET DCL(R)=$GET(DCL(R))_Z

ENDIP     ;

 +1        KILL ^UTILITY($JOB),^UTILITY("DIL",$JOB),^UTILITY("DIPZ",$JOB),DNP,DIPNCH,DIPZLR,DRN,DIPZL,DX,DXS

 +2        SET DIPZTYPE="A"

 +3        SET DRD=0

           SET DP=$PIECE(^DIPT(DIPZ,0),U,4)

           SET DHD="@"

           IF $DATA(^("DNP"))

               SET DNP=1

           IF '$DATA(^DIC(DP,0,"GL"))

               GOTO K^INHDIPZ2

           SET DK=^("GL")

           SET DRN=0

           SET R=""

           SET L=0

AF         DO INIT^DIP5

           SET X=-1

           FOR 

               SET X=$ORDER(^DIPT("AF",X))

               IF X=""

                   QUIT 

               FOR %=0:0

                   SET %=$ORDER(^DIPT("AF",X,%))

                   IF %'>0

                       QUIT 

                   IF $DATA(^(%,DIPZ))

                       KILL ^(DIPZ)

 +1        FOR C=1:1

               IF '$DATA(^DIPT(DIPZ,"DXS",C,9.2))&'$DATA(^(9))

                   QUIT 

               SET DXS(C)=""

 +2        SET IOSL=9999

           SET DL=1

           SET DIPZL=0

           SET DHT=-1

           SET C=","

           SET Q=""""

           SET ^UTILITY($JOB,1)=""

 +3        FOR DIP=-1:0

               SET DIP=$ORDER(^DIPT(DIPZ,"F",DIP))

               IF DIP=""

                   QUIT 

               SET R=^(DIP)

               DO ^DIL

 +4        IF DM

               DO UNSTACK^DIL

           DO A^DIL

           DO T^DIL2

           KILL ^DIPT(DIPZ,"T")

           FOR R=-1:0

               SET R=$ORDER(^UTILITY($JOB,"T",R))

               IF R=""

                   QUIT 

               SET ^DIPT(DIPZ,"T",R)=^(R)

 +5        SET DX=DX+999

           SET Y=$PIECE(" D ^DIWWA",1,''$DATA(DIWR))_" K Y"

           IF DIWL

               SET Y=Y_",DIWF"

               IF DIWL=1

                   SET ^UTILITY("DIPZ",$JOB,.5)=" S DIWF=""W"""

 +6        DO PX^DIPZ1

           GOTO ^INHDIPZ2

 +7       ;