- INHSGZ22 ;JSH; 16 Nov 95 17:05;Script generator - audit code
- ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
- ;COPYRIGHT 1991-2000 SAIC
- ;
- INIT ;Start to build audit routine
- D K S ARMAX=$G(^DD("ROU")) S:'ARMAX ARMAX=4000 S ARNAME="IV"_$E(SCR#100000+100000,2,6),(ARDC,ARNUM)=0
- D NEWROU Q
- ;
- K ;Kill vars
- K ^UTILITY("INAUD",$J),ARNOBRK,ARNAME,ARMAX,ARDC,ARNUM,ARDL,ARSEG,ADL,AMULT Q
- ;
- NEWROU ;Make new routine
- S ARNUM=ARNUM+1 K ^UTILITY("INAUD",$J,ARNUM) S ARLINE=0,Y=$$DT^UTDT X ^DD("DD")
- S ^UTILITY("INAUD",$J,ARNUM,1)=ARNAME_$S(ARNUM>1:$C(63+ARNUM),1:"")_" ;Audit routine for message '"_$P(MESS(0),U)_"' compiled "_Y
- S ^UTILITY("INAUD",$J,ARNUM,2)=" ;Part "_ARNUM
- S:ARNUM=1 ^UTILITY("INAUD",$J,1,2.5)="INIT S INAUDWP=0 K ^INVQA(UIF,1) Q",^(2.6)="FINISH S ^INVQA(UIF,1,0)=""^^""_+$G(INAUDWP)_""^""_+$G(INAUDWP) K ^UTILITY(""INVAUD"",$J) Q"
- S ^(3)="L(%X) ;Place line in WP field",^(4)=" S INAUDWP=INAUDWP+1,^INVQA(UIF,1,INAUDWP,0)=%X_""|CR|"" Q"
- S ^(5)="EN ;",ARLINE=5,ARSIZE=250 Q
- ;
- L(%X) ;Add line to routine
- I '$D(ARNOBRK) D:ARSIZE+$L(%X)>ARMAX
- . S ^UTILITY("INAUD",$J,ARNUM,ARLINE+1)=" G EN^"_ARNAME_$C(64+ARNUM) D NEWROU
- S ARLINE=ARLINE+1,^UTILITY("INAUD",$J,ARNUM,ARLINE)=%X,ARSIZE=ARSIZE+$L(%X) K ANOBRK Q
- ;
- FILE ;File at end
- G:'$D(^UTILITY("INAUD",$J)) K
- W ! N INI,X S INI=0 F S INI=$O(^UTILITY("INAUD",$J,INI)) Q:'INI D
- .K ^UTILITY($J,0) M ^UTILITY($J,0)=^UTILITY("INAUD",$J,INI)
- .S X=$P(^UTILITY($J,0,1)," ") X ^DD("OS",^DD("OS"),"ZS") W !,"Audit routine: "_X_" ...filed"
- G K
- ;
- SEGINIT ;Start a new segment
- D L($P(SEG(0),U,2)_" ;"_$P(SEG(0),U)) S ARSEG($P(SEG(0),U,2))=ARNUM
- D L(" Q:'$G(INAUDIT) N ZDIE,X,Y,Z S ZDIE=$E(DIE(1),1,$L(DIE(1))-1) S:ZDIE[""("" ZDIE=ZDIE_"")"" S D0=INDA")
- D:REPEAT
- . D L(" D L("""_$P(SEG(0),U,2)_" - "_$P(SEG(0),U)_" Iteration #""_INI)")
- . D L(" D L(""File: "_$O(^DD(+FILE(FLVL),0,"NM",""))_$S($D(^DD(+FILE(FLVL),0,"UP")):" SUB-FIELD",1:"")_" IEN: ""_INDA),L("""")")
- D:'REPEAT
- . D L(" D L("""_$P(SEG(0),U,2)_" - "_$P(SEG(0),U)_""")")
- . D L(" D L(""File: "_$O(^DD(+FILE(FLVL),0,"NM",""))_" IEN: ""_INDA),L("""")")
- Q
- ;
- SEGEND ;End a segment
- D L(" D L("""") Q") Q
- ;
- FIELD(%F) ;Process a field
- ;%F = dictionary number
- N I,J,DICOMP,DICOMPX,DA,DQI,DICMX,X,Z,N,C,A,B
- S I(0)="@ZDIE@(",J(0)=%F,DA="DXS(",DQI="Y(",X=DL,DICOMPX="" S:+X=X X="#"_X D ^DICOMP
- Q:'$D(X) I Y["D" S X=X_" S Y=X D DD^%DT S X=Y"
- I $D(X)>9 S I=0 F S I=$O(X(I)) Q:'I D L(" S DXS("_I_")="""_$$REPLACE^UTIL(X(I),"""","""""")_"""")
- S Z=$P(DICOMPX,";"),N=$J(INF,2),I=$E($P(^DD(+Z,$P(Z,U,2),0),U),1,16),I=I_$J("",16-$L(I)),C=$P(^DD(+Z,$P(Z,U,2),0),U,2)["C"
- I C,SLVL S A="S " D D L(" "_A_"D"_SLVL_"=INDA") S X=X_" S D0=INDA"
- . F B=1:1:SLVL S A=A_"D"_(SLVL-B)_"=INDA("_B_"),"
- D L(" "_X_" K DXS")
- D L(" S Y=^UTILITY(""INVAUD"",$J,"_$$VEXP(SVAR)_",D="" """)
- I $P(DTY(0),U,2)="DT"!($P(DTY(0),U,2)="TS")!($P(DTY(0),U,2)="CP") D L(" S Z=X,X=Y "_^INTHL7FT(DTY,2)),L(" S Y=X,X=Z")
- I $P(DTY(0),U,2)="CN"!($P(DTY(0),U,2)="ID"),MAP D L(" S Y=$$MAP^INHVA2("_MAP_",Y,0),Y=$P(Y,U,2)")
- I $P(DTY(0),U,2)="CN"!($P(DTY(0),U,2)="CP") D L(" S:$L(Y)&(Y[SUBDELIM) Y=$P(Y,SUBDELIM,2,99)")
- D L(" I X'=Y S:'(Y=""""&(X=0)) D=""*""")
- D L(" S Y=Y_$J("""",50-$L(Y)),X=X_$J("""",50-$L(X)) D L(D_"""_N_". "_I_" ""_Y_"" ""_X)")
- Q
- ;
- VEXP(V) ;Expand variable
- N X,I
- S X=""""_V_""""
- F I=1:1:SLVL S X=X_",INI"_$S(I'=SLVL:"("_I_")",1:"")
- Q X_")"
- INHSGZ22 ;JSH; 16 Nov 95 17:05;Script generator - audit code
- +1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
- +2 ;COPYRIGHT 1991-2000 SAIC
- +3 ;
- INIT ;Start to build audit routine
- +1 DO K
- SET ARMAX=$GET(^DD("ROU"))
- IF 'ARMAX
- SET ARMAX=4000
- SET ARNAME="IV"_$EXTRACT(SCR#100000+100000,2,6)
- SET (ARDC,ARNUM)=0
- +2 DO NEWROU
- QUIT
- +3 ;
- K ;Kill vars
- +1 KILL ^UTILITY("INAUD",$JOB),ARNOBRK,ARNAME,ARMAX,ARDC,ARNUM,ARDL,ARSEG,ADL,AMULT
- QUIT
- +2 ;
- NEWROU ;Make new routine
- +1 SET ARNUM=ARNUM+1
- KILL ^UTILITY("INAUD",$JOB,ARNUM)
- SET ARLINE=0
- SET Y=$$DT^UTDT
- XECUTE ^DD("DD")
- +2 SET ^UTILITY("INAUD",$JOB,ARNUM,1)=ARNAME_$SELECT(ARNUM>1:$CHAR(63+ARNUM),1:"")_" ;Audit routine for message '"_$PIECE(MESS(0),U)_"' compiled "_Y
- +3 SET ^UTILITY("INAUD",$JOB,ARNUM,2)=" ;Part "_ARNUM
- +4 IF ARNUM=1
- SET ^UTILITY("INAUD",$JOB,1,2.5)="INIT S INAUDWP=0 K ^INVQA(UIF,1) Q"
- SET ^(2.6)="FINISH S ^INVQA(UIF,1,0)=""^^""_+$G(INAUDWP)_""^""_+$G(INAUDWP) K ^UTILITY(""INVAUD"",$J) Q"
- +5 SET ^(3)="L(%X) ;Place line in WP field"
- SET ^(4)=" S INAUDWP=INAUDWP+1,^INVQA(UIF,1,INAUDWP,0)=%X_""|CR|"" Q"
- +6 SET ^(5)="EN ;"
- SET ARLINE=5
- SET ARSIZE=250
- QUIT
- +7 ;
- L(%X) ;Add line to routine
- +1 IF '$DATA(ARNOBRK)
- IF ARSIZE+$LENGTH(%X)>ARMAX
- Begin DoDot:1
- +2 SET ^UTILITY("INAUD",$JOB,ARNUM,ARLINE+1)=" G EN^"_ARNAME_$CHAR(64+ARNUM)
- DO NEWROU
- End DoDot:1
- +3 SET ARLINE=ARLINE+1
- SET ^UTILITY("INAUD",$JOB,ARNUM,ARLINE)=%X
- SET ARSIZE=ARSIZE+$LENGTH(%X)
- KILL ANOBRK
- QUIT
- +4 ;
- FILE ;File at end
- +1 IF '$DATA(^UTILITY("INAUD",$JOB))
- GOTO K
- +2 WRITE !
- NEW INI,X
- SET INI=0
- FOR
- SET INI=$ORDER(^UTILITY("INAUD",$JOB,INI))
- IF 'INI
- QUIT
- Begin DoDot:1
- +3 KILL ^UTILITY($JOB,0)
- MERGE ^UTILITY($JOB,0)=^UTILITY("INAUD",$JOB,INI)
- +4 SET X=$PIECE(^UTILITY($JOB,0,1)," ")
- XECUTE ^DD("OS",^DD("OS"),"ZS")
- WRITE !,"Audit routine: "_X_" ...filed"
- End DoDot:1
- +5 GOTO K
- +6 ;
- SEGINIT ;Start a new segment
- +1 DO L($PIECE(SEG(0),U,2)_" ;"_$PIECE(SEG(0),U))
- SET ARSEG($PIECE(SEG(0),U,2))=ARNUM
- +2 DO L">L(" Q:'$G(INAUDIT) N ZDIE,X,Y,Z S ZDIE=$E(DIE(1),1,$L">L(DIE(1))-1) S:ZDIE[""("" ZDIE=ZDIE_"")"" S D0=INDA")
- +3 IF REPEAT
- Begin DoDot:1
- +4 DO L(" D L("""_$PIECE(SEG(0),U,2)_" - "_$PIECE(SEG(0),U)_" Iteration #""_INI)")
- +5 DO L(" D L(""File: "_$ORDER(^DD(+FILE(FLVL),0,"NM",""))_$SELECT($DATA(^DD(+FILE(FLVL),0,"UP")):" SUB-FIELD",1:"")_" IEN: ""_INDA),L("""")")
- End DoDot:1
- +6 IF 'REPEAT
- Begin DoDot:1
- +7 DO L(" D L("""_$PIECE(SEG(0),U,2)_" - "_$PIECE(SEG(0),U)_""")")
- +8 DO L(" D L(""File: "_$ORDER(^DD(+FILE(FLVL),0,"NM",""))_" IEN: ""_INDA),L("""")")
- End DoDot:1
- +9 QUIT
- +10 ;
- SEGEND ;End a segment
- +1 DO L(" D L("""") Q")
- QUIT
- +2 ;
- FIELD(%F) ;Process a field
- +1 ;%F = dictionary number
- +2 NEW I,J,DICOMP,DICOMPX,DA,DQI,DICMX,X,Z,N,C,A,B
- +3 SET I(0)="@ZDIE@("
- SET J(0)=%F
- SET DA="DXS("
- SET DQI="Y("
- SET X=DL
- SET DICOMPX=""
- IF +X=X
- SET X="#"_X
- DO ^DICOMP
- +4 IF '$DATA(X)
- QUIT
- IF Y["D"
- SET X=X_" S Y=X D DD^%DT S X=Y"
- +5 IF $DATA(X)>9
- SET I=0
- FOR
- SET I=$ORDER(X(I))
- IF 'I
- QUIT
- DO L(" S DXS("_I_")="""_$$REPLACE^UTIL(X(I),"""","""""")_"""")
- +6 SET Z=$PIECE(DICOMPX,";")
- SET N=$JUSTIFY(INF,2)
- SET I=$EXTRACT($PIECE(^DD(+Z,$PIECE(Z,U,2),0),U),1,16)
- SET I=I_$JUSTIFY("",16-$LENGTH(I))
- SET C=$PIECE(^DD(+Z,$PIECE(Z,U,2),0),U,2)["C"
- +7 IF C
- IF SLVL
- SET A="S "
- Begin DoDot:1
- +8 FOR B=1:1:SLVL
- SET A=A_"D"_(SLVL-B)_"=INDA("_B_"),"
- End DoDot:1
- DO L(" "_A_"D"_SLVL_"=INDA")
- SET X=X_" S D0=INDA"
- +9 DO L(" "_X_" K DXS")
- +10 DO L(" S Y=^UTILITY(""INVAUD"",$J,"_$$VEXP(SVAR)_",D="" """)
- +11 IF $PIECE(DTY(0),U,2)="DT"!($PIECE(DTY(0),U,2)="TS")!($PIECE(DTY(0),U,2)="CP")
- DO L(" S Z=X,X=Y "_^INTHL7FT(DTY,2))
- DO L(" S Y=X,X=Z")
- +12 IF $PIECE(DTY(0),U,2)="CN"!($PIECE(DTY(0),U,2)="ID")
- IF MAP
- DO L(" S Y=$$MAP^INHVA2("_MAP_",Y,0),Y=$P(Y,U,2)")
- +13 IF $PIECE(DTY(0),U,2)="CN"!($PIECE(DTY(0),U,2)="CP")
- DO L">L(" S:$L">L(Y)&(Y[SUBDEL">LIM) Y=$P(Y,SUBDEL">LIM,2,99)")
- +14 DO L(" I X'=Y S:'(Y=""""&(X=0)) D=""*""")
- +15 DO L">L">L">L(" S Y=Y_$J("""",50-$L">L">L">L(Y)),X=X_$J("""",50-$L">L">L">L(X)) D L">L">L">L(D_"""_N_". "_I_" ""_Y_"" ""_X)")
- +16 QUIT
- +17 ;
- VEXP(V) ;Expand variable
- +1 NEW X,I
- +2 SET X=""""_V_""""
- +3 FOR I=1:1:SLVL
- SET X=X_",INI"_$SELECT(I'=SLVL:"("_I_")",1:"")
- +4 QUIT X_")"
