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