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