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