OCXOCMPM ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Compile Rule Element MetaCode) ;10/29/98 12:37
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN() ;
;
Q:$G(OCXWARN) 1
S OCXDLK=$O(^OCXS(860.6,"B","DATABASE LOOKUP",0))
S OCXEL=0 F S OCXEL=$O(^TMP("OCXCMP",$J,"ELEMENT",OCXEL)) Q:'OCXEL D Q:OCXWARN
.N OCXD1,OCXREC,OCXDFC,OCXCNT,OCXFCODE,OCXDFL,OCXSCAN
.S (OCXFCODE,OCXDFL)=""
.;
.I '$G(OCXAUTO) W:($X>60) ! W "."
.;
.M OCXREC=^OCXS(860.3,OCXEL) Q:'$D(OCXREC(0))
.S OCXNAM=$P(OCXREC(0),U,1) Q:'$L(OCXNAM)
.S OCXCON=$P(OCXREC(0),U,2) I '(OCXCON) D WARN^OCXOCMPV("Context not defined for Element...",3,OCXEL,$P($T(+1)," ",1)) Q
.I '(OCXCON) D WARN^OCXOCMPV("Context not defined for Element...",3,OCXEL,$P($T(+1)," ",1)) Q
.S OCXCONN=$P($G(^OCXS(860.6,+OCXCON,0)),U,1) I '$L(OCXCONN) D WARN^OCXOCMPV("Data context a '"_OCXCON_"' not defined in Data Context file...",4,OCXDF,$P($T(+1)," ",1)) Q
.S OCXCONA=$P($G(^OCXS(860.6,+OCXCON,0)),U,2) I '$L(OCXCONA) D WARN^OCXOCMPV("Data context abbreviation for '"_OCXCONN_"' not defined in Data Context file...",4,OCXDF,$P($T(+1)," ",1)) Q
.;
.I (OCXTRACE) D FILECODE("W:$G(OCXTRACE) !,||LNTAG||,?27,""Metacode Function MCE"_OCXEL_"() Execution trace. ""","Y")
.D FILECODE("N OCXRES","Y")
.D FILECODE("Q:'(|PATIENT IEN|) 0 I $D(^TMP(""OCXCHK"",$J,|PATIENT IEN|,"_(+OCXEL)_")) Q $G(^TMP(""OCXCHK"",$J,|PATIENT IEN|,"_(+OCXEL)_"))","Y")
.;
.I '(OCXCON=OCXDLK) D FILECODE("Q 0","Y")
.;
.I (OCXCON=OCXDLK) D
..;
..D FILECODE("S OCXRES("_(+OCXEL)_")=0","S")
..;
..; SORT PRIMARY DATA FIELDS
..;
..S OCXD1=0 F S OCXD1=$O(OCXREC("COND",OCXD1)) Q:'OCXD1 D
...N OCXDF,OCXSUB
...F OCXSUB=1,2,3 D
....N OCXFREC S OCXDF=+$G(OCXREC("COND",OCXD1,"DFLD"_OCXSUB)) Q:'OCXDF
....M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXDF)
....I '$D(OCXFREC(OCXCON)) S OCXFREC=OCXFREC-99999
....I OCXDF,OCXFREC S OCXDFC(OCXFREC,OCXD1)=OCXDF,OCXDFL(OCXDF)=""
..;
..;
..; GET PRIMARY DATA FIELD'S 'GET CODE'
..;
..S OCXCNT="" F S OCXCNT=$O(OCXDFC(OCXCNT),-1) Q:'OCXCNT D
...S OCXD1=0 F S OCXD1=$O(OCXDFC(OCXCNT,OCXD1)) Q:'OCXD1 D Q:OCXWARN
....N OCXDF,OCXD2,OCXFREC
....S OCXDF=+$G(OCXDFC(OCXCNT,OCXD1)) Q:'OCXDF
....I $D(^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXCON)) M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXCON)
....E S OCXD2=0 F S OCXD2=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXD2)) Q:'OCXD2 I $G(^(OCXD2,"DA MODE")) M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXD2) Q
....S OCXD2=0 F S OCXD2=$O(OCXFREC(OCXD2)) Q:'OCXD2 D FILECODE($G(OCXFREC(OCXD2)))
....;
....; GET EXPRESSION CONDITIONAL EVALUATION CODE
....;
....I $D(OCXFREC) D
.....N OCXCOD1,OCXCOD2,OCXCVAL,OCXFLDG,OCXFLDN,OCXFLDP,OCXFLDS,OCXDFLD
.....N OCXNAM,OCXOPER,OCXOPC,OCXD2,OCXD3,OCXP,OCXP1,OCXP2,OCXP3
.....;
.....S OCXOPER=$G(OCXREC("COND",OCXD1,"OPER"))
.....I '(OCXOPER) D WARN^OCXOCMPV("Operator/Function not defined...",3,OCXEL,$P($T(+1)," ",1)) Q
.....S OCXOPN=$P($G(^OCXS(863.9,OCXOPER,0)),U,1),OCXOPDT=$P($G(^OCXS(863.9,OCXOPER,0)),U,2)
.....I '(OCXOPDT) D WARN^OCXOCMPV("Data Type not defined for '"_OCXOPN_"' Operator",3,OCXEL,$P($T(+1)," ",1)) Q
.....I '$L($G(^OCXS(864.1,+OCXOPDT,0))) D WARN^OCXOCMPV("Data Type '"_OCXOPDT_"' not defined for '"_OCXOPN_"' Operator",3,OCXEL,$P($T(+1)," ",1)) Q
.....;
.....S OCXOPC=$$GETPARM^OCXOCMPE(39,OCXOPER,"OCXO GENERATE CODE FUNCTION")
.....I '$L(OCXOPC) D WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' parameter not defined",3,OCXEL,$P($T(+1)," ",1)) Q
.....S:'(OCXOPC=+OCXOPC) OCXOPC=$$GETIEN("^OCXS(863.7)",OCXOPC)
.....I '$D(^OCXS(863.7,+OCXOPC,0)) D WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' Public Function not defined",3,OCXEL,$P($T(+1)," ",1)) Q
.....S OCXP=$G(^OCXS(863.7,+OCXOPC,"EX")) I '$L(OCXP) D WARN^OCXOCMPV("Operator ("_(+OCXOPC)_") '"_$P($G(^OCXS(863.9,+OCXOPC,0)),U,1)_"' executable not defined",3,OCXEL,$P($T(+1)," ",1)) Q
.....S OCXD2=0 F S OCXD2=$O(^OCXS(863.7,+OCXOPC,"PAR",OCXD2)) Q:'OCXD2 D
......N OCXPOS,OCXVNAM
......S OCXPOS=+$G(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,"IN")) Q:'OCXPOS Q:$D(OCXP(OCXPOS))
......S OCXVNAM=+$G(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,0)) Q:'OCXVNAM
......S OCXVNAM=$P($G(^OCXS(863.8,+OCXVNAM,0)),U,2) Q:'$L(OCXVNAM)
......S OCXP(+OCXPOS)=OCXVNAM,OCXP(OCXVNAM)=""
......;
.....D GETC^OCXOCMPE(OCXEL,OCXD1,.OCXP)
..D FILECODE("E Q 0","Y")
..;
..; GATHER OUTPUT DATA FOR THIS ELEMENT-EVENT
..;
..S OCXDF=0 F S OCXDF=$O(^TMP("OCXCMP",$J,"ELEMENT",OCXEL,"DATA",OCXDF)) Q:'OCXDF D
...N OCXCON,OCXFREC S OCXCON=$P($G(^OCXS(860.3,OCXEL,0)),U,2)
...I $D(^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXDLK)) M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXDLK)
...E D
....I '$G(OCXAUTO) D
.....W !
.....W !,"Database Lookup Method not defined for:"
.....W !," '"_$P($G(^OCXS(860.3,+OCXEL,0)),U,1)_"'"
.....W !," ( "_(+OCXDF)_" ) "_$P($G(^OCXS(860.4,+OCXDF,0)),U,1)
....M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXCON)
...I '$L($G(OCXFREC("G"))) D WARN^OCXOCMPV("CMP2 Get data code not defined for '"_$P($G(^OCXS(860.4,+OCXDF,0)),U,1)_"' ( "_(+OCXDF)_" )",2,OCXEL,$P($T(+1)," ",1)) Q
...S OCXDFL(OCXDF)=+$G(^TMP("OCXCMP",$J,"ELEMENT",OCXEL,"DATA",OCXDF))
...S OCXD2=0 F S OCXD2=$O(OCXFREC(OCXD2)) Q:'OCXD2 I $L($G(OCXFREC(OCXD2))) D
....D FILECODE(OCXFREC(OCXD2),$G(OCXFREC(OCXD2,"OPLIST")))
..;
..; FILE ELEMENT-EVENT IN ACTIVE PATIENT DATA FILE
..;
..S OCXDFL="",OCXDF=0 F S OCXDF=$O(OCXDFL(OCXDF)) Q:'OCXDF S:$L(OCXDFL) OCXDFL=OCXDFL_"," S OCXDFL=OCXDFL_OCXDF_$S(OCXDFL(OCXDF):"X",1:"")
..;
..D FILECODE("S OCXRES("_(+OCXEL)_")=11","S")
..D FILECODE("M ^TMP(""OCXCHK"",$J,|PATIENT IEN|,"_(+OCXEL)_")=OCXRES("_(+OCXEL)_")","M")
..D FILECODE("Q +OCXRES("_(+OCXEL)_")","Y")
.;
.; RESOLVE EXTRINSIC FUNCTON RUNTIME PARAMETERS
.;
.F D Q:'OCXSCAN Q:OCXWARN
..S (OCXSCAN,OCXD2)=0 F S OCXD2=$O(OCXFCODE(OCXD2)) Q:'OCXD2 I $L(OCXFCODE(OCXD2)),(OCXFCODE(OCXD2)["|") D
...N OCXPIEC,DFNAM,DFNUM,DFCODE
...S DFCODE=OCXFCODE(OCXD2)
...F OCXPIEC=2:2:$L(DFCODE,"|") S DFNAM=$P($P(DFCODE,"|",OCXPIEC),"|",1) I $L(DFNAM),'(DFNAM["""") S DFNAM(DFNAM)=""
...S DFNAM="" F S DFNAM=$O(DFNAM(DFNAM)) Q:'$L(DFNAM) D
....N DFBNAM,DFNUM,OCXFREC,OCXD3
....S DFBNAM="|"_DFNAM_"|",OCXSCAN=1
....S DFNUM=+$O(^OCXS(860.4,"B",DFNAM,0))
....I 'DFNUM S DFNUM=+$O(^OCXS(860.4,"C",DFNAM,0))
....I 'DFNUM D WARN^OCXOCMPV("Data field argument '"_DFNAM_"' not defined in Data Field file...",3,OCXEL,$P($T(+1)," ",1)) Q
....I $D(^TMP("OCXCMP",$J,"DATA FIELD",DFNUM,OCXCON)) M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",DFNUM,OCXCON)
....E I $D(^TMP("OCXCMP",$J,"DATA FIELD",DFNUM,OCXDLK)) M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",DFNUM,OCXDLK)
....E S OCXD3=0 F S OCXD3=$O(^TMP("OCXCMP",$J,"DATA FIELD",DFNUM,OCXD3)) Q:'OCXD3 I $G(^(OCXD3,"DA MODE")) M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",DFNUM,OCXD3) Q
....I '$D(OCXFREC) D WARN^OCXOCMPV("Data field '"_DFNAM_"' get code not defined for '"_OCXCONN_" context...",3,OCXEL,$P($T(+1)," ",1)) Q
....S OCXFREC($O(OCXFREC(99999),-1)+1)="I $L(OCXDF("_(+DFNUM)_"))"
....S OCXD3=0 F S OCXD3=$O(OCXFREC(OCXD3)) Q:'OCXD3 D FILECODE($G(OCXFREC(OCXD3)),$G(OCXFREC(OCXD3,"OPLIST")),OCXD2)
....F Q:'(DFCODE[DFBNAM) S DFCODE=$P(DFCODE,DFBNAM,1)_"OCXDF("_(+DFNUM)_")"_$P(DFCODE,DFBNAM,2,999)
...S OCXFCODE(OCXD2)=DFCODE
..;
..; PURGE REDUNDANT CODE
..;
..S OCXD2=0 F S OCXD2=$O(OCXFCODE(OCXD2)) Q:'OCXD2 D
...I (OCXFCODE(OCXD2)="||NOOP||") K OCXFCODE(OCXD2) Q
...I '$D(OCXFCODE(OCXD2,"OPLIST")) D
....I '(OCXFCODE(OCXD2)["OCXTRACE") S OCXFCODE(OCXD2,"OPLIST")=$E(OCXFCODE(OCXD2),1)
....E S OCXFCODE(OCXD2,"OPLIST")="Y"
...S OCXD3=OCXD2 F S OCXD3=$O(OCXFCODE(OCXD3)) Q:'OCXD3 D
....Q:(OCXFCODE(OCXD2)["OCXBOOLV")
....I (OCXFCODE(OCXD2)=OCXFCODE(OCXD3)) K OCXFCODE(OCXD3)
..D REINDEX(.OCXFCODE,0)
.;
.; SAVE CODE IN ^TMP GLOBAL
.;
.D MC^OCXOCMPN(.OCXFCODE,OCXEL)
.;
.D REINDEX(.OCXFCODE,2)
.S OCXCOD0="MCE"_OCXEL
.S OCXD2=0 F S OCXD2=$O(OCXFCODE(OCXD2)) Q:'OCXD2 D
..K OCXFCODE(OCXD2,"OPLIST")
..S OCXFCODE(OCXD2)=" "_OCXFCODE(OCXD2)
.S OCXFCODE(1)=OCXCOD0_"() ; Verify Event/Element: "_$P($G(^OCXS(860.3,+OCXEL,0)),U,1)
.S OCXFCODE(2)=" ;"
.S OCXFCODE($O(OCXFCODE(" "),-1)+1)=" ;"
.S OCXD2=0 F S OCXD2=$O(OCXFCODE(OCXD2)) Q:'OCXD2 D
..N TEMP
..S TEMP=OCXFCODE(OCXD2)
..K OCXFCODE(OCXD2)
..S OCXFCODE(OCXD2,0)=TEMP
.M ^TMP("OCXCMP",$J,"INCLUDE",OCXCOD0)=OCXFCODE
;
Q OCXWARN
;
GETIEN(FILE,KEY) ;
;
N IEN1,IEN2,LEN,SHORT
F LEN=$L(KEY):-1:0 I LEN Q:$D(@FILE@("B",$E(KEY,1,LEN)))
Q:'LEN 0 S SHORT=$E(KEY,1,LEN)
S IEN1=0 F S IEN1=$O(@FILE@("B",SHORT,IEN1)) Q:'IEN1 Q:($P($G(@FILE@(IEN1,0)),U,1)=KEY)
S IEN2=IEN1 F S IEN2=$O(@FILE@("B",SHORT,IEN2)) Q:'IEN2 Q:($P($G(@FILE@(IEN2,0)),U,1)=KEY)
;
I IEN1,IEN2 Q -1
Q IEN1
;
REINDEX(ARRAY,NDX2) ;
;
N TEMP,NDX1 M TEMP=ARRAY K ARRAY
S NDX1="" F S NDX1=$O(TEMP(NDX1)) Q:'$L(NDX1) D
.I $L(TEMP(NDX1)) S NDX2=NDX2+1 M ARRAY(NDX2)=TEMP(NDX1)
Q
;
FILECODE(CODE,OPLIST,INDEX) ;
;
N OCXNDX
I $G(INDEX) D
.N PREV,HALF
.S PREV=$O(OCXFCODE(INDEX),-1),HALF=INDEX-PREV/2
.S OCXNDX=INDEX-HALF
E S OCXNDX=$O(OCXFCODE(""),-1)+1
S OCXFCODE(OCXNDX)=CODE
S:$L($G(OPLIST)) OCXFCODE(OCXNDX,"OPLIST")=OPLIST
Q
;
OCXOCMPM ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Compile Rule Element MetaCode) ;10/29/98 12:37
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
EN() ;
+1 ;
+2 IF $GET(OCXWARN)
QUIT 1
+3 SET OCXDLK=$ORDER(^OCXS(860.6,"B","DATABASE LOOKUP",0))
+4 SET OCXEL=0
FOR
SET OCXEL=$ORDER(^TMP("OCXCMP",$JOB,"ELEMENT",OCXEL))
IF 'OCXEL
QUIT
Begin DoDot:1
+5 NEW OCXD1,OCXREC,OCXDFC,OCXCNT,OCXFCODE,OCXDFL,OCXSCAN
+6 SET (OCXFCODE,OCXDFL)=""
+7 ;
+8 IF '$GET(OCXAUTO)
IF ($X>60)
WRITE !
WRITE "."
+9 ;
+10 MERGE OCXREC=^OCXS(860.3,OCXEL)
IF '$DATA(OCXREC(0))
QUIT
+11 SET OCXNAM=$PIECE(OCXREC(0),U,1)
IF '$LENGTH(OCXNAM)
QUIT
+12 SET OCXCON=$PIECE(OCXREC(0),U,2)
IF '(OCXCON)
DO WARN^OCXOCMPV("Context not defined for Element...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+13 IF '(OCXCON)
DO WARN^OCXOCMPV("Context not defined for Element...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+14 SET OCXCONN=$PIECE($GET(^OCXS(860.6,+OCXCON,0)),U,1)
IF '$LENGTH(OCXCONN)
DO WARN^OCXOCMPV("Data context a '"_OCXCON_"' not defined in Data Context file...",4,OCXDF,$PIECE($TEXT(+1)," ",1))
QUIT
+15 SET OCXCONA=$PIECE($GET(^OCXS(860.6,+OCXCON,0)),U,2)
IF '$LENGTH(OCXCONA)
DO WARN^OCXOCMPV("Data context abbreviation for '"_OCXCONN_"' not defined in Data Context file...",4,OCXDF,$PIECE($TEXT(+1)," ",1))
QUIT
+16 ;
+17 IF (OCXTRACE)
DO FILECODE("W:$G(OCXTRACE) !,||LNTAG||,?27,""Metacode Function MCE"_OCXEL_"() Execution trace. ""","Y")
+18 DO FILECODE("N OCXRES","Y")
+19 DO FILECODE("Q:'(|PATIENT IEN|) 0 I $D(^TMP(""OCXCHK"",$J,|PATIENT IEN|,"_(+OCXEL)_")) Q $G(^TMP(""OCXCHK"",$J,|PATIENT IEN|,"_(+OCXEL)_"))","Y")
+20 ;
+21 IF '(OCXCON=OCXDLK)
DO FILECODE("Q 0","Y")
+22 ;
+23 IF (OCXCON=OCXDLK)
Begin DoDot:2
+24 ;
+25 DO FILECODE("S OCXRES("_(+OCXEL)_")=0","S")
+26 ;
+27 ; SORT PRIMARY DATA FIELDS
+28 ;
+29 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXREC("COND",OCXD1))
IF 'OCXD1
QUIT
Begin DoDot:3
+30 NEW OCXDF,OCXSUB
+31 FOR OCXSUB=1,2,3
Begin DoDot:4
+32 NEW OCXFREC
SET OCXDF=+$GET(OCXREC("COND",OCXD1,"DFLD"_OCXSUB))
IF 'OCXDF
QUIT
+33 MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF)
+34 IF '$DATA(OCXFREC(OCXCON))
SET OCXFREC=OCXFREC-99999
+35 IF OCXDF
IF OCXFREC
SET OCXDFC(OCXFREC,OCXD1)=OCXDF
SET OCXDFL(OCXDF)=""
End DoDot:4
End DoDot:3
+36 ;
+37 ;
+38 ; GET PRIMARY DATA FIELD'S 'GET CODE'
+39 ;
+40 SET OCXCNT=""
FOR
SET OCXCNT=$ORDER(OCXDFC(OCXCNT),-1)
IF 'OCXCNT
QUIT
Begin DoDot:3
+41 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXDFC(OCXCNT,OCXD1))
IF 'OCXD1
QUIT
Begin DoDot:4
+42 NEW OCXDF,OCXD2,OCXFREC
+43 SET OCXDF=+$GET(OCXDFC(OCXCNT,OCXD1))
IF 'OCXDF
QUIT
+44 IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXCON))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXCON)
+45 IF '$TEST
SET OCXD2=0
FOR
SET OCXD2=$ORDER(^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXD2))
IF 'OCXD2
QUIT
IF $GET(^(OCXD2,"DA MODE"))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXD2)
QUIT
+46 SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFREC(OCXD2))
IF 'OCXD2
QUIT
DO FILECODE($GET(OCXFREC(OCXD2)))
+47 ;
+48 ; GET EXPRESSION CONDITIONAL EVALUATION CODE
+49 ;
+50 IF $DATA(OCXFREC)
Begin DoDot:5
+51 NEW OCXCOD1,OCXCOD2,OCXCVAL,OCXFLDG,OCXFLDN,OCXFLDP,OCXFLDS,OCXDFLD
+52 NEW OCXNAM,OCXOPER,OCXOPC,OCXD2,OCXD3,OCXP,OCXP1,OCXP2,OCXP3
+53 ;
+54 SET OCXOPER=$GET(OCXREC("COND",OCXD1,"OPER"))
+55 IF '(OCXOPER)
DO WARN^OCXOCMPV("Operator/Function not defined...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+56 SET OCXOPN=$PIECE($GET(^OCXS(863.9,OCXOPER,0)),U,1)
SET OCXOPDT=$PIECE($GET(^OCXS(863.9,OCXOPER,0)),U,2)
+57 IF '(OCXOPDT)
DO WARN^OCXOCMPV("Data Type not defined for '"_OCXOPN_"' Operator",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+58 IF '$LENGTH($GET(^OCXS(864.1,+OCXOPDT,0)))
DO WARN^OCXOCMPV("Data Type '"_OCXOPDT_"' not defined for '"_OCXOPN_"' Operator",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+59 ;
+60 SET OCXOPC=$$GETPARM^OCXOCMPE(39,OCXOPER,"OCXO GENERATE CODE FUNCTION")
+61 IF '$LENGTH(OCXOPC)
DO WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' parameter not defined",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+62 IF '(OCXOPC=+OCXOPC)
SET OCXOPC=$$GETIEN("^OCXS(863.7)",OCXOPC)
+63 IF '$DATA(^OCXS(863.7,+OCXOPC,0))
DO WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' Public Function not defined",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+64 SET OCXP=$GET(^OCXS(863.7,+OCXOPC,"EX"))
IF '$LENGTH(OCXP)
DO WARN^OCXOCMPV("Operator ("_(+OCXOPC)_") '"_$PIECE($GET(^OCXS(863.9,+OCXOPC,0)),U,1)_"' executable not defined",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+65 SET OCXD2=0
FOR
SET OCXD2=$ORDER(^OCXS(863.7,+OCXOPC,"PAR",OCXD2))
IF 'OCXD2
QUIT
Begin DoDot:6
+66 NEW OCXPOS,OCXVNAM
+67 SET OCXPOS=+$GET(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,"IN"))
IF 'OCXPOS
QUIT
IF $DATA(OCXP(OCXPOS))
QUIT
+68 SET OCXVNAM=+$GET(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,0))
IF 'OCXVNAM
QUIT
+69 SET OCXVNAM=$PIECE($GET(^OCXS(863.8,+OCXVNAM,0)),U,2)
IF '$LENGTH(OCXVNAM)
QUIT
+70 SET OCXP(+OCXPOS)=OCXVNAM
SET OCXP(OCXVNAM)=""
+71 ;
End DoDot:6
+72 DO GETC^OCXOCMPE(OCXEL,OCXD1,.OCXP)
End DoDot:5
End DoDot:4
IF OCXWARN
QUIT
End DoDot:3
+73 DO FILECODE("E Q 0","Y")
+74 ;
+75 ; GATHER OUTPUT DATA FOR THIS ELEMENT-EVENT
+76 ;
+77 SET OCXDF=0
FOR
SET OCXDF=$ORDER(^TMP("OCXCMP",$JOB,"ELEMENT",OCXEL,"DATA",OCXDF))
IF 'OCXDF
QUIT
Begin DoDot:3
+78 NEW OCXCON,OCXFREC
SET OCXCON=$PIECE($GET(^OCXS(860.3,OCXEL,0)),U,2)
+79 IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXDLK))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXDLK)
+80 IF '$TEST
Begin DoDot:4
+81 IF '$GET(OCXAUTO)
Begin DoDot:5
+82 WRITE !
+83 WRITE !,"Database Lookup Method not defined for:"
+84 WRITE !," '"_$PIECE($GET(^OCXS(860.3,+OCXEL,0)),U,1)_"'"
+85 WRITE !," ( "_(+OCXDF)_" ) "_$PIECE($GET(^OCXS(860.4,+OCXDF,0)),U,1)
End DoDot:5
+86 MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXCON)
End DoDot:4
+87 IF '$LENGTH($GET(OCXFREC("G")))
DO WARN^OCXOCMPV("CMP2 Get data code not defined for '"_$PIECE($GET(^OCXS(860.4,+OCXDF,0)),U,1)_"' ( "_(+OCXDF)_" )",2,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+88 SET OCXDFL(OCXDF)=+$GET(^TMP("OCXCMP",$JOB,"ELEMENT",OCXEL,"DATA",OCXDF))
+89 SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFREC(OCXD2))
IF 'OCXD2
QUIT
IF $LENGTH($GET(OCXFREC(OCXD2)))
Begin DoDot:4
+90 DO FILECODE(OCXFREC(OCXD2),$GET(OCXFREC(OCXD2,"OPLIST")))
End DoDot:4
End DoDot:3
+91 ;
+92 ; FILE ELEMENT-EVENT IN ACTIVE PATIENT DATA FILE
+93 ;
+94 SET OCXDFL=""
SET OCXDF=0
FOR
SET OCXDF=$ORDER(OCXDFL(OCXDF))
IF 'OCXDF
QUIT
IF $LENGTH(OCXDFL)
SET OCXDFL=OCXDFL_","
SET OCXDFL=OCXDFL_OCXDF_$SELECT(OCXDFL(OCXDF):"X",1:"")
+95 ;
+96 DO FILECODE("S OCXRES("_(+OCXEL)_")=11","S")
+97 DO FILECODE("M ^TMP(""OCXCHK"",$J,|PATIENT IEN|,"_(+OCXEL)_")=OCXRES("_(+OCXEL)_")","M")
+98 DO FILECODE("Q +OCXRES("_(+OCXEL)_")","Y")
End DoDot:2
+99 ;
+100 ; RESOLVE EXTRINSIC FUNCTON RUNTIME PARAMETERS
+101 ;
+102 FOR
Begin DoDot:2
+103 SET (OCXSCAN,OCXD2)=0
FOR
SET OCXD2=$ORDER(OCXFCODE(OCXD2))
IF 'OCXD2
QUIT
IF $LENGTH(OCXFCODE(OCXD2))
IF (OCXFCODE(OCXD2)["|")
Begin DoDot:3
+104 NEW OCXPIEC,DFNAM,DFNUM,DFCODE
+105 SET DFCODE=OCXFCODE(OCXD2)
+106 FOR OCXPIEC=2:2:$LENGTH(DFCODE,"|")
SET DFNAM=$PIECE($PIECE(DFCODE,"|",OCXPIEC),"|",1)
IF $LENGTH(DFNAM)
IF '(DFNAM["""")
SET DFNAM(DFNAM)=""
+107 SET DFNAM=""
FOR
SET DFNAM=$ORDER(DFNAM(DFNAM))
IF '$LENGTH(DFNAM)
QUIT
Begin DoDot:4
+108 NEW DFBNAM,DFNUM,OCXFREC,OCXD3
+109 SET DFBNAM="|"_DFNAM_"|"
SET OCXSCAN=1
+110 SET DFNUM=+$ORDER(^OCXS(860.4,"B",DFNAM,0))
+111 IF 'DFNUM
SET DFNUM=+$ORDER(^OCXS(860.4,"C",DFNAM,0))
+112 IF 'DFNUM
DO WARN^OCXOCMPV("Data field argument '"_DFNAM_"' not defined in Data Field file...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+113 IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXCON))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXCON)
+114 IF '$TEST
IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXDLK))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXDLK)
+115 IF '$TEST
SET OCXD3=0
FOR
SET OCXD3=$ORDER(^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXD3))
IF 'OCXD3
QUIT
IF $GET(^(OCXD3,"DA MODE"))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXD3)
QUIT
+116 IF '$DATA(OCXFREC)
DO WARN^OCXOCMPV("Data field '"_DFNAM_"' get code not defined for '"_OCXCONN_" context...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+117 SET OCXFREC($ORDER(OCXFREC(99999),-1)+1)="I $L(OCXDF("_(+DFNUM)_"))"
+118 SET OCXD3=0
FOR
SET OCXD3=$ORDER(OCXFREC(OCXD3))
IF 'OCXD3
QUIT
DO FILECODE($GET(OCXFREC(OCXD3)),$GET(OCXFREC(OCXD3,"OPLIST")),OCXD2)
+119 FOR
IF '(DFCODE[DFBNAM)
QUIT
SET DFCODE=$PIECE(DFCODE,DFBNAM,1)_"OCXDF("_(+DFNUM)_")"_$PIECE(DFCODE,DFBNAM,2,999)
End DoDot:4
+120 SET OCXFCODE(OCXD2)=DFCODE
End DoDot:3
+121 ;
+122 ; PURGE REDUNDANT CODE
+123 ;
+124 SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFCODE(OCXD2))
IF 'OCXD2
QUIT
Begin DoDot:3
+125 IF (OCXFCODE(OCXD2)="||NOOP||")
KILL OCXFCODE(OCXD2)
QUIT
+126 IF '$DATA(OCXFCODE(OCXD2,"OPLIST"))
Begin DoDot:4
+127 IF '(OCXFCODE(OCXD2)["OCXTRACE")
SET OCXFCODE(OCXD2,"OPLIST")=$EXTRACT(OCXFCODE(OCXD2),1)
+128 IF '$TEST
SET OCXFCODE(OCXD2,"OPLIST")="Y"
End DoDot:4
+129 SET OCXD3=OCXD2
FOR
SET OCXD3=$ORDER(OCXFCODE(OCXD3))
IF 'OCXD3
QUIT
Begin DoDot:4
+130 IF (OCXFCODE(OCXD2)["OCXBOOLV")
QUIT
+131 IF (OCXFCODE(OCXD2)=OCXFCODE(OCXD3))
KILL OCXFCODE(OCXD3)
End DoDot:4
End DoDot:3
+132 DO REINDEX(.OCXFCODE,0)
End DoDot:2
IF 'OCXSCAN
QUIT
IF OCXWARN
QUIT
+133 ;
+134 ; SAVE CODE IN ^TMP GLOBAL
+135 ;
+136 DO MC^OCXOCMPN(.OCXFCODE,OCXEL)
+137 ;
+138 DO REINDEX(.OCXFCODE,2)
+139 SET OCXCOD0="MCE"_OCXEL
+140 SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFCODE(OCXD2))
IF 'OCXD2
QUIT
Begin DoDot:2
+141 KILL OCXFCODE(OCXD2,"OPLIST")
+142 SET OCXFCODE(OCXD2)=" "_OCXFCODE(OCXD2)
End DoDot:2
+143 SET OCXFCODE(1)=OCXCOD0_"() ; Verify Event/Element: "_$PIECE($GET(^OCXS(860.3,+OCXEL,0)),U,1)
+144 SET OCXFCODE(2)=" ;"
+145 SET OCXFCODE($ORDER(OCXFCODE(" "),-1)+1)=" ;"
+146 SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFCODE(OCXD2))
IF 'OCXD2
QUIT
Begin DoDot:2
+147 NEW TEMP
+148 SET TEMP=OCXFCODE(OCXD2)
+149 KILL OCXFCODE(OCXD2)
+150 SET OCXFCODE(OCXD2,0)=TEMP
End DoDot:2
+151 MERGE ^TMP("OCXCMP",$JOB,"INCLUDE",OCXCOD0)=OCXFCODE
End DoDot:1
IF OCXWARN
QUIT
+152 ;
+153 QUIT OCXWARN
+154 ;
GETIEN(FILE,KEY) ;
+1 ;
+2 NEW IEN1,IEN2,LEN,SHORT
+3 FOR LEN=$LENGTH(KEY):-1:0
IF LEN
IF $DATA(@FILE@("B",$EXTRACT(KEY,1,LEN)))
QUIT
+4 IF 'LEN
QUIT 0
SET SHORT=$EXTRACT(KEY,1,LEN)
+5 SET IEN1=0
FOR
SET IEN1=$ORDER(@FILE@("B",SHORT,IEN1))
IF 'IEN1
QUIT
IF ($PIECE($GET(@FILE@(IEN1,0)),U,1)=KEY)
QUIT
+6 SET IEN2=IEN1
FOR
SET IEN2=$ORDER(@FILE@("B",SHORT,IEN2))
IF 'IEN2
QUIT
IF ($PIECE($GET(@FILE@(IEN2,0)),U,1)=KEY)
QUIT
+7 ;
+8 IF IEN1
IF IEN2
QUIT -1
+9 QUIT IEN1
+10 ;
REINDEX(ARRAY,NDX2) ;
+1 ;
+2 NEW TEMP,NDX1
MERGE TEMP=ARRAY
KILL ARRAY
+3 SET NDX1=""
FOR
SET NDX1=$ORDER(TEMP(NDX1))
IF '$LENGTH(NDX1)
QUIT
Begin DoDot:1
+4 IF $LENGTH(TEMP(NDX1))
SET NDX2=NDX2+1
MERGE ARRAY(NDX2)=TEMP(NDX1)
End DoDot:1
+5 QUIT
+6 ;
FILECODE(CODE,OPLIST,INDEX) ;
+1 ;
+2 NEW OCXNDX
+3 IF $GET(INDEX)
Begin DoDot:1
+4 NEW PREV,HALF
+5 SET PREV=$ORDER(OCXFCODE(INDEX),-1)
SET HALF=INDEX-PREV/2
+6 SET OCXNDX=INDEX-HALF
End DoDot:1
+7 IF '$TEST
SET OCXNDX=$ORDER(OCXFCODE(""),-1)+1
+8 SET OCXFCODE(OCXNDX)=CODE
+9 IF $LENGTH($GET(OPLIST))
SET OCXFCODE(OCXNDX,"OPLIST")=OPLIST
+10 QUIT
+11 ;
