INHSZ ;JSH; 15 Oct 1999 15:41 ;Interface Script compiler
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;CHCS TOOLS_460; GEN 6; 8-APR-1997
;COPYRIGHT 1988, 1989, 1990 SAIC
;
I $G(^DD("OS",^DD("OS"),"ZS"))="" W *7,!,"Your operating system does not allow saving a routine.",!! Q
N SCR,DIC,Y,STR
S DIC="^INRHS(",DIC(0)="QAE",DIC("A")="Select SCRIPT to Compile: ",DIC("S")="I '$P(^(0),U,4)" D ^DIC Q:Y<0 S SCR=+Y
EN ;Enter here with SCR = script # to compile
Q:'$D(^INRHS(SCR))
L +^INRHS(SCR):0 E W !,*7,"Another user is working with this script." Q
N INDUZ M INDUZ=DUZ N DUZ S DUZ(0)="@",DUZ("AG")=$G(INDUZ("AG"))
N DOT,INDL,MAX,INDS,INDE,ROU,INSTD,STR
;S MAX=+$G(^DD("ROU")) S:'MAX MAX=6000 S MAX=MAX-500 cmi/maw orig
S MAX=+$G(^DD("ROU")) S:'MAX MAX=10000 S MAX=MAX-500 ;cmi/maw mod
S DT=$$DT^UTDT
;Set flag for interface standard (stored in field .07)
S INSTD=$P(^INRHS(SCR,0),U,7),INSTD=$S(INSTD="NCPDP":"NC",INSTD="X12":"X12",INSTD="HL7":"HL",1:"HL")
W !!,"Compiling Script: ",$P(^INRHS(SCR,0),U),!
S ROU="IS"_$E(SCR#100000+100000,2,6) K ^UTILITY("IN",$J)
I $$^INHSZ1(SCR) D
.D FILE
E D:$G(^UTILITY("INHSYS_FILERR",$J)) SUMERR^INHSYS11($P(^INRHS(SCR,0),U)_" not compiled.")
L -^INRHS(SCR)
Q
;
ASBL(SCR) ;Assemble script lines SCR = script #
S L="",V="^UTILITY(""IN"",$J,""L"")",(C0,C1,C,LVL)=0
S I=0 F S I=$O(^INRHS(SCR,1,I)) Q:'I S X=^(I,0) S:'$O(^INRHS(SCR,1,I)) X=X_"|CR|" D
. I X'["|CR|" D Q
.. I $L(L)+$L(X)'>255 S L=L_X Q
.. F Q:X="" D
... S Z=255-$L(L),L=L_$E(X,1,Z),X=$E(X,Z+1,999) Q:$L(L)'=255
... S C=C+1,@V@(C)=L,L="" D:'LVL DOWN Q
.; X now contains a |CR|
. F Q:X'["|CR|" D
.. S L1=$P(X,"|CR|"),X=$P(X,"|CR|",2,999)
.. I $L(L1)+$L(L)<256 S C=C+1,@V@(C)=L_L1 D:LVL UP S L="" Q
.. S Z=255-$L(L),L=L_$E(L1,1,Z),L1=$E(L1,Z+1,999),C=C+1,@V@(C)=L D:'LVL DOWN S C=C+1,@V@(C)=L1,L="" D UP Q
Q
;
DOWN ;Move down 1 level
S C0=C,V="^UTILITY(""IN"",$J,""L"","_C0_")",C=0,LVL=1 Q
;
UP ;Move up to top level
S V="^UTILITY(""IN"",$J,""L"")",C=C0,LVL=0 Q
;
FILE ;File the routine(s) created
W !,"Linking... "
N C,RN,LC,LVL,DOT,CS,MODE,STRIP,INZS,%REF,DATE,RMAX
S MODE=$E($P(^INRHS(SCR,0),U,2))
S C=0,RN=1,(LC,LVL,STRIP)=0,Y=DT D DD^%DT S DATE=Y K DOT
F D Q:'$O(^UTILITY("IN",$J,"R",C))
. ;S (A,CS)=0,L=1 S X=ROU_$S(RN=1:"",1:$C(RN+63)) K ^UTILITY("IN",$J,RN) maw orig line
. S (A,CS)=0,L=1 S X=ROU_$S(RN=1:"",RN>27:$C(RN+69),1:$C(RN+63)) K ^UTILITY("IN",$J,RN) ;cmi/sitka/maw modified for more routines
. I RN=1 D
.. I MODE="O" S X=X_"(INTT,INDA,INA,INDEST,INQUE,INORDUZ,INORDIV)"
.. E S X=X_"(UIF,INOA,INODA)"
.. S X=X_" ;Compiled from script '"_$P(^INRHS(SCR,0),U)_"' on "_DATE,^UTILITY("IN",$J,RN,L)=X,CS=CS+X
. E S ^UTILITY("IN",$J,RN,L)=X_" ;Compiled from script '"_$P(^INRHS(SCR,0),U)_"' on "_DATE,CS=CS+$L(^UTILITY("IN",$J,RN,L))+2
. S L=L+1,^UTILITY("IN",$J,RN,L)=" ;Part "_RN,CS=CS+$L(^(L))+2
. S L=L+1,^UTILITY("IN",$J,RN,L)=" ;Copyright "_$$DATEFMT^UTDT(DT,"YYYY")_" SAIC",CS=CS+$L(^UTILITY("IN",$J,RN,L))+2 I $P(^UTILITY("IN",$J,"R",C+1)," ")="" S $P(^(C+1)," ")="EN",STRIP=$$NUMDOTS(^(C+1))
. F S C=C+1 Q:'$D(^UTILITY("IN",$J,"R",C)) Q:CS+$L($G(^UTILITY("IN",$J,"R",C)))+13>MAX&'A D
.. S A=0
.. S L=L+1,^UTILITY("IN",$J,RN,L)=$$STRIP(^UTILITY("IN",$J,"R",C),STRIP),CS=CS+$L(^UTILITY("IN",$J,RN,L))+2
.. I $D(INDL(C)) S $P(INDL(C),U,2)=RN_U_(LVL-STRIP) S LVL=LVL+1
.. I $D(INDE(C)) S LVL0=$P(INDL(+INDE(C)),U,3),SR=$P(INDL(+INDE(C)),U,2) S:SR'=RN TAG=$$TAG(LC)_LVL,$P(INDE(C),U,2)=TAG,DOT(SR,999-LVL0)=LVL0_U_RN_U_TAG S LVL=LVL-1,A=1 S:'LVL LC=LC+1 D:SR'=RN
... S $P(^UTILITY("IN",$J,"R",C+1)," ")=TAG,STRIP=$$NUMDOTS(^(C+1))
. S C=C-1
. I $O(^UTILITY("IN",$J,"R",C)),'$D(INDE(C+1)) D
.. ;S L=L+1,^UTILITY("IN",$J,RN,L)="9 "_$E("...............",1,LVL-STRIP)_$S(LVL-STRIP:"D",1:"G")_" EN^"_ROU_$C(RN+64) maw orig
.. S L=L+1,^UTILITY("IN",$J,RN,L)="9 "_$E("...............",1,LVL-STRIP)_$S(LVL-STRIP:"D",1:"G")_" EN^"_ROU_$S(RN>26:$C(RN+70),1:$C(RN+64)) ;maw mod for more routines
. S ^UTILITY("IN",$J,RN)=L,RN=RN+1
F1 ;Do the filing
W " Filing generated routines...",!
S INZS=$$REPLACE^UTIL(^DD("OS",^DD("OS"),"ZS"),"^UTILITY($J,0,","@%REF@("),I=0 F S I=$O(^UTILITY("IN",$J,I)) Q:'I S RMAX=I D
. S %REF="^UTILITY(""IN"",$J,"_I_")"
. ;S X=ROU_$S(I=1:"",1:$C(I+63)) maw orig
. S X=ROU_$S(I=1:"",I>27:$C(I+69),1:$C(I+63)) ;maw modified
. I $D(DOT(I)) D
.. S L=^UTILITY("IN",$J,I)
.. ;S J=0 F S J=$O(DOT(I,J)) Q:'J S LVL=999-J,L=L+1,@%REF@(L)=" "_$E("...............",1,LVL)_$S(LVL:"D",1:"G")_" "_$P(DOT(I,J),U,3)_"^"_ROU_$C(63+$P(DOT(I,J),U,2)) ;maw orig
.. S J=0 F S J=$O(DOT(I,J)) Q:'J S LVL=999-J,L=L+1,@%REF@(L)=" "_$E("...............",1,LVL)_$S(LVL:"D",1:"G")_" "_$P(DOT(I,J),U,3)_"^"_ROU_$S($P(DOT(I,J),U,2)>27:$C(69+$P(DOT(I,J),U,2)),1:$C(63+$P(DOT(I,J),U,2))) ;maw modified
. X INZS W !,"Routine ",X,?19,"...Filed"
S $P(^INRHS(SCR,0),U,6)=RMAX K ^UTILITY("IN",$J),^UTILITY($J)
Q
;
TAG(X) ;Return tag for #X
I X<52 Q $C($S(X<26:65,1:71)+X)
Q $C(64+(X\52))_$C($S((X#52)<26:65,1:71)+(X#52))
;
RECOMP ;Recompile all scripts
F SCR=0:0 S SCR=$O(^INRHS(SCR)) Q:'SCR D EN:'$P(^(SCR,0),U,4)
Q
;
NUMDOTS(%L) ;Returns number of dots at start of %L
N X S %L=$P(%L," ",2,999),X=1
NM0 Q:$E(%L,X)'="." X-1 S X=X+1 G NM0
;
STRIP(%L,%N) ;Strip %N dots from front of %L
Q:'%N %L
Q $P(%L," ")_" "_$P($P(%L," ",2,999),$E("..............",1,%N),2,999)
INHSZ ;JSH; 15 Oct 1999 15:41 ;Interface Script compiler
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;CHCS TOOLS_460; GEN 6; 8-APR-1997
+4 ;COPYRIGHT 1988, 1989, 1990 SAIC
+5 ;
+6 IF $GET(^DD("OS",^DD("OS"),"ZS"))=""
WRITE *7,!,"Your operating system does not allow saving a routine.",!!
QUIT
+7 NEW SCR,DIC,Y,STR
+8 SET DIC="^INRHS("
SET DIC(0)="QAE"
SET DIC("A")="Select SCRIPT to Compile: "
SET DIC("S")="I '$P(^(0),U,4)"
DO ^DIC
IF Y<0
QUIT
SET SCR=+Y
EN ;Enter here with SCR = script # to compile
+1 IF '$DATA(^INRHS(SCR))
QUIT
+2 LOCK +^INRHS(SCR):0
IF '$TEST
WRITE !,*7,"Another user is working with this script."
QUIT
+3 NEW INDUZ
MERGE INDUZ=DUZ
NEW DUZ
SET DUZ(0)="@"
SET DUZ("AG")=$GET(INDUZ("AG"))
+4 NEW DOT,INDL,MAX,INDS,INDE,ROU,INSTD,STR
+5 ;S MAX=+$G(^DD("ROU")) S:'MAX MAX=6000 S MAX=MAX-500 cmi/maw orig
+6 ;cmi/maw mod
SET MAX=+$GET(^DD("ROU"))
IF 'MAX
SET MAX=10000
SET MAX=MAX-500
+7 SET DT=$$DT^UTDT
+8 ;Set flag for interface standard (stored in field .07)
+9 SET INSTD=$PIECE(^INRHS(SCR,0),U,7)
SET INSTD=$SELECT(INSTD="NCPDP":"NC",INSTD="X12":"X12",INSTD="HL7":"HL",1:"HL")
+10 WRITE !!,"Compiling Script: ",$PIECE(^INRHS(SCR,0),U),!
+11 SET ROU="IS"_$EXTRACT(SCR#100000+100000,2,6)
KILL ^UTILITY("IN",$JOB)
+12 IF $$^INHSZ1(SCR)
Begin DoDot:1
+13 DO FILE
End DoDot:1
+14 IF '$TEST
IF $GET(^UTILITY("INHSYS_FILERR",$JOB))
DO SUMERR^INHSYS11($PIECE(^INRHS(SCR,0),U)_" not compiled.")
+15 LOCK -^INRHS(SCR)
+16 QUIT
+17 ;
ASBL(SCR) ;Assemble script lines SCR = script #
+1 SET L=""
SET V="^UTILITY(""IN"",$J,""L"")"
SET (C0,C1,C,LVL)=0
+2 SET I=0
FOR
SET I=$ORDER(^INRHS(SCR,1,I))
IF 'I
QUIT
SET X=^(I,0)
IF '$ORDER(^INRHS(SCR,1,I))
SET X=X_"|CR|"
Begin DoDot:1
+3 IF X'["|CR|"
Begin DoDot:2
+4 IF $LENGTH(L)+$LENGTH(X)'>255
SET L=L_X
QUIT
+5 FOR
IF X=""
QUIT
Begin DoDot:3
+6 SET Z=255-$LENGTH(L)
SET L=L_$EXTRACT(X,1,Z)
SET X=$EXTRACT(X,Z+1,999)
IF $LENGTH(L)'=255
QUIT
+7 SET C=C+1
SET @V@(C)=L
SET L=""
IF 'LVL
DO DOWN
QUIT
End DoDot:3
End DoDot:2
QUIT
+8 ; X now contains a |CR|
+9 FOR
IF X'["|CR|"
QUIT
Begin DoDot:2
+10 SET L1=$PIECE(X,"|CR|")
SET X=$PIECE(X,"|CR|",2,999)
+11 IF $LENGTH(L1)+$LENGTH(L)<256
SET C=C+1
SET @V@(C)=L_L1
IF LVL
DO UP
SET L=""
QUIT
+12 SET Z=255-$LENGTH(L)
SET L=L_$EXTRACT(L1,1,Z)
SET L1=$EXTRACT(L1,Z+1,999)
SET C=C+1
SET @V@(C)=L
IF 'LVL
DO DOWN
SET C=C+1
SET @V@(C)=L1
SET L=""
DO UP
QUIT
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
DOWN ;Move down 1 level
+1 SET C0=C
SET V="^UTILITY(""IN"",$J,""L"","_C0_")"
SET C=0
SET LVL=1
QUIT
+2 ;
UP ;Move up to top level
+1 SET V="^UTILITY(""IN"",$J,""L"")"
SET C=C0
SET LVL=0
QUIT
+2 ;
FILE ;File the routine(s) created
+1 WRITE !,"Linking... "
+2 NEW C,RN,LC,LVL,DOT,CS,MODE,STRIP,INZS,%REF,DATE,RMAX
+3 SET MODE=$EXTRACT($PIECE(^INRHS(SCR,0),U,2))
+4 SET C=0
SET RN=1
SET (LC,LVL,STRIP)=0
SET Y=DT
DO DD^%DT
SET DATE=Y
KILL DOT
+5 FOR
Begin DoDot:1
+6 ;S (A,CS)=0,L=1 S X=ROU_$S(RN=1:"",1:$C(RN+63)) K ^UTILITY("IN",$J,RN) maw orig line
+7 ;cmi/sitka/maw modified for more routines
SET (A,CS)=0
SET L=1
SET X=ROU_$SELECT(RN=1:"",RN>27:$CHAR(RN+69),1:$CHAR(RN+63))
KILL ^UTILITY("IN",$JOB,RN)
+8 IF RN=1
Begin DoDot:2
+9 IF MODE="O"
SET X=X_"(INTT,INDA,INA,INDEST,INQUE,INORDUZ,INORDIV)"
+10 IF '$TEST
SET X=X_"(UIF,INOA,INODA)"
+11 SET X=X_" ;Compiled from script '"_$PIECE(^INRHS(SCR,0),U)_"' on "_DATE
SET ^UTILITY("IN",$JOB,RN,L)=X
SET CS=CS+X
End DoDot:2
+12 IF '$TEST
SET ^UTILITY("IN",$JOB,RN,L)=X_" ;Compiled from script '"_$PIECE(^INRHS(SCR,0),U)_"' on "_DATE
SET CS=CS+$LENGTH(^UTILITY("IN",$JOB,RN,L))+2
+13 SET L=L+1
SET ^UTILITY("IN",$JOB,RN,L)=" ;Part "_RN
SET CS=CS+$LENGTH(^(L))+2
+14 SET L=L+1
SET ^UTILITY("IN",$JOB,RN,L)=" ;Copyright "_$$DATEFMT^UTDT(DT,"YYYY")_" SAIC"
SET CS=CS+$LENGTH(^UTILITY("IN",$JOB,RN,L))+2
IF $PIECE(^UTILITY("IN",$JOB,"R",C+1)," ")=""
SET $PIECE(^(C+1)," ")="EN"
SET STRIP=$$NUMDOTS(^(C+1))
+15 FOR
SET C=C+1
IF '$DATA(^UTILITY("IN",$JOB,"R",C))
QUIT
IF CS+$LENGTH($GET(^UTILITY("IN",$JOB,"R",C)))+13>MAX&'A
QUIT
Begin DoDot:2
+16 SET A=0
+17 SET L=L+1
SET ^UTILITY("IN",$JOB,RN,L)=$$STRIP(^UTILITY("IN",$JOB,"R",C),STRIP)
SET CS=CS+$LENGTH(^UTILITY("IN",$JOB,RN,L))+2
+18 IF $DATA(INDL(C))
SET $PIECE(INDL(C),U,2)=RN_U_(LVL-STRIP)
SET LVL=LVL+1
+19 IF $DATA(INDE(C))
SET LVL0=$PIECE(INDL(+INDE(C)),U,3)
SET SR=$PIECE(INDL(+INDE(C)),U,2)
IF SR'=RN
SET TAG=$$TAG(LC)_LVL
SET $PIECE(INDE(C),U,2)=TAG
SET DOT(SR,999-LVL0)=LVL0_U_RN_U_TAG
SET LVL=LVL-1
SET A=1
IF 'LVL
SET LC=LC+1
IF SR'=RN
Begin DoDot:3
+20 SET $PIECE(^UTILITY("IN",$JOB,"R",C+1)," ")=TAG
SET STRIP=$$NUMDOTS(^(C+1))
End DoDot:3
End DoDot:2
+21 SET C=C-1
+22 IF $ORDER(^UTILITY("IN",$JOB,"R",C))
IF '$DATA(INDE(C+1))
Begin DoDot:2
+23 ;S L=L+1,^UTILITY("IN",$J,RN,L)="9 "_$E("...............",1,LVL-STRIP)_$S(LVL-STRIP:"D",1:"G")_" EN^"_ROU_$C(RN+64) maw orig
+24 ;maw mod for more routines
SET L=L+1
SET ^UTILITY("IN",$JOB,RN,L)="9 "_$EXTRACT("...............",1,LVL-STRIP)_$SELECT(LVL-STRIP:"D",1:"G")_" EN^"_ROU_$SELECT(RN>26:$CHAR(RN+70),1:$CHAR(RN+64))
End DoDot:2
+25 SET ^UTILITY("IN",$JOB,RN)=L
SET RN=RN+1
End DoDot:1
IF '$ORDER(^UTILITY("IN",$JOB,"R",C))
QUIT
F1 ;Do the filing
+1 WRITE " Filing generated routines...",!
+2 SET INZS=$$REPLACE^UTIL(^DD("OS",^DD("OS"),"ZS"),"^UTILITY($J,0,","@%REF@(")
SET I=0
FOR
SET I=$ORDER(^UTILITY("IN",$JOB,I))
IF 'I
QUIT
SET RMAX=I
Begin DoDot:1
+3 SET %REF="^UTILITY(""IN"",$J,"_I_")"
+4 ;S X=ROU_$S(I=1:"",1:$C(I+63)) maw orig
+5 ;maw modified
SET X=ROU_$SELECT(I=1:"",I>27:$CHAR(I+69),1:$CHAR(I+63))
+6 IF $DATA(DOT(I))
Begin DoDot:2
+7 SET L=^UTILITY("IN",$JOB,I)
+8 ;S J=0 F S J=$O(DOT(I,J)) Q:'J S LVL=999-J,L=L+1,@%REF@(L)=" "_$E("...............",1,LVL)_$S(LVL:"D",1:"G")_" "_$P(DOT(I,J),U,3)_"^"_ROU_$C(63+$P(DOT(I,J),U,2)) ;maw orig
+9 ;maw modified
SET J=0
FOR
SET J=$ORDER(DOT(I,J))
IF 'J
QUIT
SET LVL=999-J
SET L=L+1
SET @%REF@(L)=" "_$EXTRACT("...............",1,LVL)_$SELECT(LVL:"D",1:"G")_" "_$PIECE(DOT(I,J),U,3)_"^"_ROU_$SELECT($PIECE(DOT(I,J),U,2)>27:$CHAR(69+$PIECE(DOT(I,J),U,2)),1:$CHAR(63+$PIECE(DOT(I,J),U,2)))
End DoDot:2
+10 XECUTE INZS
WRITE !,"Routine ",X,?19,"...Filed"
End DoDot:1
+11 SET $PIECE(^INRHS(SCR,0),U,6)=RMAX
KILL ^UTILITY("IN",$JOB),^UTILITY($JOB)
+12 QUIT
+13 ;
TAG(X) ;Return tag for #X
+1 IF X<52
QUIT $CHAR($SELECT(X<26:65,1:71)+X)
+2 QUIT $CHAR(64+(X\52))_$CHAR($SELECT((X#52)<26:65,1:71)+(X#52))
+3 ;
RECOMP ;Recompile all scripts
+1 FOR SCR=0:0
SET SCR=$ORDER(^INRHS(SCR))
IF 'SCR
QUIT
IF '$PIECE(^(SCR,0),U,4)
DO EN
+2 QUIT
+3 ;
NUMDOTS(%L) ;Returns number of dots at start of %L
+1 NEW X
SET %L=$PIECE(%L," ",2,999)
SET X=1
NM0 IF $EXTRACT(%L,X)'="."
QUIT X-1
SET X=X+1
GOTO NM0
+1 ;
STRIP(%L,%N) ;Strip %N dots from front of %L
+1 IF '%N
QUIT %L
+2 QUIT $PIECE(%L," ")_" "_$PIECE($PIECE(%L," ",2,999),$EXTRACT("..............",1,%N),2,999)
