INHSC ;JSH; 11 Jul 94 15:55;Create/Edit a script
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
N DIC,I,NAME,X,Y,DIK,DIE,DA,DR
A S DIC="^INRHS(",DIC(0)="E",DIC("S")="I '$P(^(0),U,5)"
W !! D ^UTSRD("Select SCRIPT to edit: ",1) Q:X=""!($E(X)="^")
D ^DIC G:X["?" A I Y>0 S DA=+Y D ED G A
X $P(^DD(4006,.01,0),U,5,999) I '$D(X) W *7," ??" G A
W *7 S NAME=X S X=$$YN^UTSRD(" Are you adding a new script? ;1","") I 'X W " ??",*7 G A
S DA=$$MAKENEW Q:'DA
S ^DIJUSV(DUZ,"^INRHS(")=DA,^INRHS(DA,0)=NAME,DIK="^INRHS(" D IX1^DIK
W ! S X=$$YN^UTSRD("Is this script going to be an INCLUDE for another script? ;0","") Q:X["^"
S $P(^INRHS(DA,0),U,4)=+X G:X 1
S DR=".02;.03",DIE="^INRHS(" D ^DIE S X=$P(^INRHS(DA,0),U,2,3)
I X'?1A1"^"1.NP W *7,!?5,"<Script '"_$P(^INRHS(DA,0),U)_"' Deleted>" S DIK=DIE D ^DIK G A
D TEMP($E(X))
1 D ED G A
;
MAKENEW() ;Make a new script and return its IEN
N I,X
L +^INRHS(0) F I=1:1 Q:'$D(^INRHS(I))
I I>99999 W *7,!,"No space for additional scripts.",! L -^INRHS(0) Q ""
S ^INRHS(I,0)="",X=$P(^INRHS(0),U,4),X=X+1,$P(^INRHS(0),U,4)=X
S X=$P(^(0),U,3) I I>X S $P(^(0),U,3)=I
L -^INRHS(0) Q I
;
ED ;Edit DA=script number
N INDA,INON,INRMAX
S:$P(^INRHS(DA,0),U,4) INON=1
S INDA=DA,DIE="^INRHS(",INRMAX=$P(^INRHS(DA,0),U,6)
I $$SC^INHUTIL1 S DWN="INH SCRIPT EDIT" D ^DWC G:'$D(^INRHS(INDA,0)) SDEL D EDSCR^INHI(INDA) G ED1
S DR="[INH SCRIPT EDIT]" D ^DIE G:'$D(^INRHS(DA,0)) SDEL
ED1 Q:$P(^INRHS(DA,0),U,4)
W !! S X=$$YN^UTSRD("Compile Script? ;1","") Q:'X
S SCR=DA G EN^INHSZ
;
SDEL ;Script INDA deleted, INRMAX = number of compiled routines
S:'$G(INRMAX) INRMAX=10 S R="IS"_$E(INDA#100000+100000,2,6)
F I=1:1:INRMAX S X=R_$S(I=1:"",1:$C(63+I)) X ^%ZOSF("DEL") W !,X_" routine deleted."
K I,X,R Q
;
KILL(DA) ;Kill script DA
Q:'$D(^INRHS(DA,0))
N INRMAX S INRMAX=$P(^INRHS(DA,0),U,6)
S INDA=DA,DIK="^INRHS(" D ^DIK G SDEL
;
TEMP(%M) ;Load initial script template
;%M = I or O
N %,I,X,%1
D:'$D(DT) SETDT^UTDT
S %=0 F I=1:1 S X=$T(TEXT+I) Q:'$L(X) S %1=$P(X,";",2) I '$L(%1)!(%1=%M) S %=%+1,^INRHS(DA,1,%,0)=$P(X,";",3,99)_"|CR|"
S ^INRHS(DA,1,0)=U_U_%_U_%_U_DT
Q
;
PRINT ;Print a script
N D0,ROU,ZTSK,IOP,DUOUT,PAGE,FILE,DIR,NAME,INON
S DIC=4006,DIC(0)="QAEM",DIC("A")="Select SCRIPT to Print: "
D ^DIC Q:Y<0 S D0=+Y
K IOP S %ZIS="NMQ" D ^%ZIS Q:POP S IOP=ION_";"_IOST_";"_IOM_";"_IOSL
I IO'=IO(0) D D ^%ZISC Q
. S ZTSAVE("D0")="",ZTSAVE("DTIME")=""
. S ZTRTN="ZTSK^INHSC",ZTIO=IOP D ^%ZTLOAD W !?5,"Request "_$S($D(ZTSK):"",1:"NOT ")_"QUEUED."
S %ZIS="" D ^%ZIS
ZTSK ;TaskMan entry point - enter with D0 set to entry #
S U="^",PAGE=0
X $P(^DD(4006,1,0),U,5,99) S ROU=X S FILE=$P($G(^DIC(+$P(^INRHS(D0,0),U,3),0)),U),DIR=$P("IN^OUT",U,$P(^INRHS(D0,0),U,2)="O"+1),NAME=$P(^INRHS(D0,0),U),INON=$P(^(0),U,4)
K ^UTILITY("IN",$J) D ASBL^INHSZ(D0) ;Assemble lines
W:'$D(ZTSK) @IOF D HEAD
S I=0 F S I=$O(^UTILITY("IN",$J,"L",I)) Q:'I D Q:$G(DUOUT)
. I $Y+3>IOSL D HEAD Q:$G(DUOUT)
. S L=^(I),N=0 W !,I,".",?7
. I $L(L)<(IOM-10) W L Q
. W $E(L,1,IOM-10) S L=$E(L,IOM-9,999)
. F Q:'$L(L)&'$O(^UTILITY("IN",$J,"L",I,N)) D Q:$G(DUOUT)
.. I $Y+3>IOSL D HEAD Q:$G(DUOUT)
.. S X=$E(L,1,IOM-10),L=$E(L,IOM-9,999) I $L(X)<(IOM-10),$O(^UTILITY("IN",$J,"L",I,N)) S N=$O(^(N)),L=^(N),X=X_$E(L,1,(IOM-10)-$L(X)),L=$E(L,(IOM-10)-$L(X)+1,999)
.. W !?10,X
I $D(ZTSK) K ^%ZTSK(ZTSK) W @IOF
K ^UTILITY("IN",$J) D ^%ZISC Q
;
HEAD ;Script header
K DUOUT
I IO=IO(0),'$D(ZTSK),$E(IOST,1,2)="C-",PAGE W !,*7 R X:DTIME S:$E(X)=U DUOUT=1
Q:$G(DUOUT)
W:PAGE @IOF S PAGE=PAGE+1
W !,"Script Name:",?18,NAME
I 'INON W !,"Compiled Routine:",?18,ROU,!,"File:",?18,$E(FILE,1,30),?50,"Direction: ",DIR
E W " (Include Only)"
W ! K Z S $P(Z,"-",IOM+1)="" W Z
Q
TEXT ;Lines of text for initial script
;;;
;;
;;DATA:
;;;Data Section
;;DELIM=
;;SUBDELIM=
;;
;;
;;
;I;TRANS:
;I;;Transform Section
;I;
;I;
;I;REQUIRED:
;I;;Required Section
;I;
;I;
;I;
;I;LOOKUP:
;I;;Lookup Section
;I;IDENT
;I;MATCH
;I;PARAM
;I;
;I;STORE:
;I;;Store Section
;I;ROUTINE=
;I;TEMPLATE=
;I;
;;END:
INHSC ;JSH; 11 Jul 94 15:55;Create/Edit a script
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 NEW DIC,I,NAME,X,Y,DIK,DIE,DA,DR
A SET DIC="^INRHS("
SET DIC(0)="E"
SET DIC("S")="I '$P(^(0),U,5)"
+1 WRITE !!
DO ^UTSRD("Select SCRIPT to edit: ",1)
IF X=""!($EXTRACT(X)="^")
QUIT
+2 DO ^DIC
IF X["?"
GOTO A
IF Y>0
SET DA=+Y
DO ED
GOTO A
+3 XECUTE $PIECE(^DD(4006,.01,0),U,5,999)
IF '$DATA(X)
WRITE *7," ??"
GOTO A
+4 WRITE *7
SET NAME=X
SET X=$$YN^UTSRD(" Are you adding a new script? ;1","")
IF 'X
WRITE " ??",*7
GOTO A
+5 SET DA=$$MAKENEW
IF 'DA
QUIT
+6 SET ^DIJUSV(DUZ,"^INRHS(")=DA
SET ^INRHS(DA,0)=NAME
SET DIK="^INRHS("
DO IX1^DIK
+7 WRITE !
SET X=$$YN^UTSRD("Is this script going to be an INCLUDE for another script? ;0","")
IF X["^"
QUIT
+8 SET $PIECE(^INRHS(DA,0),U,4)=+X
IF X
GOTO 1
+9 SET DR=".02;.03"
SET DIE="^INRHS("
DO ^DIE
SET X=$PIECE(^INRHS(DA,0),U,2,3)
+10 IF X'?1A1"^"1.NP
WRITE *7,!?5,"<Script '"_$PIECE(^INRHS(DA,0),U)_"' Deleted>"
SET DIK=DIE
DO ^DIK
GOTO A
+11 DO TEMP($EXTRACT(X))
1 DO ED
GOTO A
+1 ;
MAKENEW() ;Make a new script and return its IEN
+1 NEW I,X
+2 LOCK +^INRHS(0)
FOR I=1:1
IF '$DATA(^INRHS(I))
QUIT
+3 IF I>99999
WRITE *7,!,"No space for additional scripts.",!
LOCK -^INRHS(0)
QUIT ""
+4 SET ^INRHS(I,0)=""
SET X=$PIECE(^INRHS(0),U,4)
SET X=X+1
SET $PIECE(^INRHS(0),U,4)=X
+5 SET X=$PIECE(^(0),U,3)
IF I>X
SET $PIECE(^(0),U,3)=I
+6 LOCK -^INRHS(0)
QUIT I
+7 ;
ED ;Edit DA=script number
+1 NEW INDA,INON,INRMAX
+2 IF $PIECE(^INRHS(DA,0),U,4)
SET INON=1
+3 SET INDA=DA
SET DIE="^INRHS("
SET INRMAX=$PIECE(^INRHS(DA,0),U,6)
+4 IF $$SC^INHUTIL1
SET DWN="INH SCRIPT EDIT"
DO ^DWC
IF '$DATA(^INRHS(INDA,0))
GOTO SDEL
DO EDSCR^INHI(INDA)
GOTO ED1
+5 SET DR="[INH SCRIPT EDIT]"
DO ^DIE
IF '$DATA(^INRHS(DA,0))
GOTO SDEL
ED1 IF $PIECE(^INRHS(DA,0),U,4)
QUIT
+1 WRITE !!
SET X=$$YN^UTSRD("Compile Script? ;1","")
IF 'X
QUIT
+2 SET SCR=DA
GOTO EN^INHSZ
+3 ;
SDEL ;Script INDA deleted, INRMAX = number of compiled routines
+1 IF '$GET(INRMAX)
SET INRMAX=10
SET R="IS"_$EXTRACT(INDA#100000+100000,2,6)
+2 FOR I=1:1:INRMAX
SET X=R_$SELECT(I=1:"",1:$CHAR(63+I))
XECUTE ^%ZOSF("DEL")
WRITE !,X_" routine deleted."
+3 KILL I,X,R
QUIT
+4 ;
KILL(DA) ;Kill script DA
+1 IF '$DATA(^INRHS(DA,0))
QUIT
+2 NEW INRMAX
SET INRMAX=$PIECE(^INRHS(DA,0),U,6)
+3 SET INDA=DA
SET DIK="^INRHS("
DO ^DIK
GOTO SDEL
+4 ;
TEMP(%M) ;Load initial script template
+1 ;%M = I or O
+2 NEW %,I,X,%1
+3 IF '$DATA(DT)
DO SETDT^UTDT
+4 SET %=0
FOR I=1:1
SET X=$TEXT(TEXT+I)
IF '$LENGTH(X)
QUIT
SET %1=$PIECE(X,";",2)
IF '$LENGTH(%1)!(%1=%M)
SET %=%+1
SET ^INRHS(DA,1,%,0)=$PIECE(X,";",3,99)_"|CR|"
+5 SET ^INRHS(DA,1,0)=U_U_%_U_%_U_DT
+6 QUIT
+7 ;
PRINT ;Print a script
+1 NEW D0,ROU,ZTSK,IOP,DUOUT,PAGE,FILE,DIR,NAME,INON
+2 SET DIC=4006
SET DIC(0)="QAEM"
SET DIC("A")="Select SCRIPT to Print: "
+3 DO ^DIC
IF Y<0
QUIT
SET D0=+Y
+4 KILL IOP
SET %ZIS="NMQ"
DO ^%ZIS
IF POP
QUIT
SET IOP=ION_";"_IOST_";"_IOM_";"_IOSL
+5 IF IO'=IO(0)
Begin DoDot:1
+6 SET ZTSAVE("D0")=""
SET ZTSAVE("DTIME")=""
+7 SET ZTRTN="ZTSK^INHSC"
SET ZTIO=IOP
DO ^%ZTLOAD
WRITE !?5,"Request "_$SELECT($DATA(ZTSK):"",1:"NOT ")_"QUEUED."
End DoDot:1
DO ^%ZISC
QUIT
+8 SET %ZIS=""
DO ^%ZIS
ZTSK ;TaskMan entry point - enter with D0 set to entry #
+1 SET U="^"
SET PAGE=0
+2 XECUTE $PIECE(^DD(4006,1,0),U,5,99)
SET ROU=X
SET FILE=$PIECE($GET(^DIC(+$PIECE(^INRHS(D0,0),U,3),0)),U)
SET DIR=$PIECE("IN^OUT",U,$PIECE(^INRHS(D0,0),U,2)="O"+1)
SET NAME=$PIECE(^INRHS(D0,0),U)
SET INON=$PIECE(^(0),U,4)
+3 ;Assemble lines
KILL ^UTILITY("IN",$JOB)
DO ASBL^INHSZ(D0)
+4 IF '$DATA(ZTSK)
WRITE @IOF
DO HEAD
+5 SET I=0
FOR
SET I=$ORDER(^UTILITY("IN",$JOB,"L",I))
IF 'I
QUIT
Begin DoDot:1
+6 IF $Y+3>IOSL
DO HEAD
IF $GET(DUOUT)
QUIT
+7 SET L=^(I)
SET N=0
WRITE !,I,".",?7
+8 IF $LENGTH(L)<(IOM-10)
WRITE L
QUIT
+9 WRITE $EXTRACT(L,1,IOM-10)
SET L=$EXTRACT(L,IOM-9,999)
+10 FOR
IF '$LENGTH(L)&'$ORDER(^UTILITY("IN",$JOB,"L",I,N))
QUIT
Begin DoDot:2
+11 IF $Y+3>IOSL
DO HEAD
IF $GET(DUOUT)
QUIT
+12 SET X=$EXTRACT(L,1,IOM-10)
SET L=$EXTRACT(L,IOM-9,999)
IF $LENGTH(X)<(IOM-10)
IF $ORDER(^UTILITY("IN",$JOB,"L",I,N))
SET N=$ORDER(^(N))
SET L=^(N)
SET X=X_$EXTRACT(L,1,(IOM-10)-$LENGTH(X))
SET L=$EXTRACT(L,(IOM-10)-$LENGTH(X)+1,999)
+13 WRITE !?10,X
End DoDot:2
IF $GET(DUOUT)
QUIT
End DoDot:1
IF $GET(DUOUT)
QUIT
+14 IF $DATA(ZTSK)
KILL ^%ZTSK(ZTSK)
WRITE @IOF
+15 KILL ^UTILITY("IN",$JOB)
DO ^%ZISC
QUIT
+16 ;
HEAD ;Script header
+1 KILL DUOUT
+2 IF IO=IO(0)
IF '$DATA(ZTSK)
IF $EXTRACT(IOST,1,2)="C-"
IF PAGE
WRITE !,*7
READ X:DTIME
IF $EXTRACT(X)=U
SET DUOUT=1
+3 IF $GET(DUOUT)
QUIT
+4 IF PAGE
WRITE @IOF
SET PAGE=PAGE+1
+5 WRITE !,"Script Name:",?18,NAME
+6 IF 'INON
WRITE !,"Compiled Routine:",?18,ROU,!,"File:",?18,$EXTRACT(FILE,1,30),?50,"Direction: ",DIR
+7 IF '$TEST
WRITE " (Include Only)"
+8 WRITE !
KILL Z
SET $PIECE(Z,"-",IOM+1)=""
WRITE Z
+9 QUIT
TEXT ;Lines of text for initial script
+1 ;;;
+2 ;;
+3 ;;DATA:
+4 ;;;Data Section
+5 ;;DELIM=
+6 ;;SUBDELIM=
+7 ;;
+8 ;;
+9 ;;
+10 ;I;TRANS:
+11 ;I;;Transform Section
+12 ;I;
+13 ;I;
+14 ;I;REQUIRED:
+15 ;I;;Required Section
+16 ;I;
+17 ;I;
+18 ;I;
+19 ;I;LOOKUP:
+20 ;I;;Lookup Section
+21 ;I;IDENT
+22 ;I;MATCH
+23 ;I;PARAM
+24 ;I;
+25 ;I;STORE:
+26 ;I;;Store Section
+27 ;I;ROUTINE=
+28 ;I;TEMPLATE=
+29 ;I;
+30 ;;END:
