OCXOCMP2 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Compile Rule Element Evaluation Code) ;3/20/01 16:12
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN() ;
;
Q:$G(OCXWARN) OCXWARN
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 OCXD0,OCXD1,OCXREC,OCXDFC,OCXCF,OCXCNT1,OCXCNT2,OCXFCODE,OCXDFL,OCXSCAN,OCXSORT
.S (OCXFCODE,OCXDFL)=""
.K OCXREC 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
.Q:(OCXCON=OCXDLK)
.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 (OCXCONN="TIMED ORDER CHECK") D I 1
..D FILECODE("I ($G(OCXOSRC)="""_OCXCONN_"""),($D(OCXOSRC(""ELEMENT"","_OCXEL_")))","Y")
.E D FILECODE("I ($G(OCXOSRC)="""_OCXCONN_""")","Y")
.;
.I '$G(OCXAUTO) W:($X>60) ! W "."
.K OCXSORT
.S OCXD1=0 F S OCXD1=$O(OCXREC("COND",OCXD1)) Q:'OCXD1 D Q:OCXWARN
..N OCXSUB
..F OCXSUB=1,2,3 D Q:OCXWARN
...N OCXDF,OCXFREC,OCXCNT
...S OCXDF=+$G(OCXREC("COND",OCXD1,"DFLD"_OCXSUB)) Q:'OCXDF
...K OCXFREC M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXDF)
...S OCXCNT=+$G(OCXFREC)
...I '$D(OCXFREC(OCXCON)) S OCXCNT=OCXCNT+99999 I '$D(OCXFREC(OCXDLK)) D Q
....D WARN^OCXOCMPV("Cannot resolve Navigation code for Data Field "_OCXCONN_" context...",4,OCXDF,$P($T(+1)," ",1)) Q
...S OCXSORT(OCXD1)=$G(OCXSORT(OCXD1))+OCXCNT
...S OCXSORT(OCXD1,OCXCNT,OCXDF)=""
.;
.S OCXD1=0 F S OCXD1=$O(OCXSORT(OCXD1)) Q:'OCXD1 S OCXSORT("A",OCXSORT(OCXD1),OCXD1)=""
.;
.Q:OCXWARN
.;
.; GET PRIMARY DATA FIELD'S 'GET CODE'
.;
.S OCXCNT1=0 F S OCXCNT1=$O(OCXSORT("A",OCXCNT1)) Q:'OCXCNT1 D
..S OCXD1=0 F S OCXD1=$O(OCXSORT("A",OCXCNT1,OCXD1)) Q:'OCXD1 D Q:OCXWARN
...N OCXDF,OCXD2,OCXFREC K OCXFREC
...S OCXCNT2=0 F S OCXCNT2=$O(OCXSORT(OCXD1,OCXCNT2)) Q:'OCXCNT2 D Q:OCXWARN
....S OCXDF=0 F S OCXDF=$O(OCXSORT(OCXD1,OCXCNT2,OCXDF)) Q:'OCXDF D Q:OCXWARN
.....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
...;
...Q:'$D(OCXFREC)
...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)
.;
.; 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 'OCXCON D WARN^OCXOCMPV("CMP2 Data context not defined for '"_$P($G(^OCXS(860.3,+OCXEL,0)),U,1)_"' ( "_(+OCXDF)_" )",2,OCXEL,$P($T(+1)," ",1)) Q
..I $D(^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXCON)) M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXCON)
..E M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXDF,OCXDLK)
..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:"")
.;
.I OCXTLOG D
..N OCXX,OPCODE
..S OCXX="S OCXOERR=$$TIMELOG(""O"",""FILE"")"
..S OCXX=OCXX_",OCXOERR=$$FILE(DFN,"_OCXEL_","""_OCXDFL_""")"
..S OCXX=OCXX_",OCXOERR=$$TIMELOG(""I"",""FILE"")"
..D FILECODE(OCXX,"SHS")
.I 'OCXTLOG D FILECODE("S OCXOERR=$$FILE(DFN,"_OCXEL_","""_OCXDFL_""") Q:OCXOERR ","SQ")
.;
.; RESOLVE EXTRINSIC FUNCTON RUNTIME PARAMETERS
.;
.S OCXSCAN=0 F D Q:'OCXSCAN Q:OCXWARN
..S OCXSCAN=0 S 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
..;
..D PURGE(.OCXFCODE)
.;
.I (OCXTLOG) S OCXD2=0 F S OCXD2=$O(OCXFCODE(OCXD2)) Q:'OCXD2 I (OCXFCODE(OCXD2)["$$"),'(OCXFCODE(OCXD2)["$$TIMELOG") D
..N OCXX,OPCODE
..S OPCODE=$E(OCXFCODE(OCXD2),1)
..S OCXX="S OCXOERR=$$TIMELOG(""O"","""_$P($P(OCXFCODE(OCXD2),"$$",2)_"(","(",1)_""")"
..S OCXX=OCXX_" "_OCXFCODE(OCXD2)
..S OCXX=OCXX_" S OCXOERR=$$TIMELOG(""I"","""_$P($P(OCXFCODE(OCXD2),"$$",2)_"(","(",1)_""")"
..S OCXFCODE(OCXD2)=OCXX
..S OCXFCODE(OCXD2,"OPLIST")="SH"_OPCODE_"S"
.;
.;
.; PURGE AND REINDEX CODE
.;
.D PURGE(.OCXFCODE)
.;
.; SAVE CODE IN ^TMP GLOBAL
.;
.S OCXCOD0=$O(^TMP("OCXCMP",$J,"A CODE",99999),-1)+1
.;
.M ^TMP("OCXCMP",$J,"A CODE",OCXCOD0)=OCXFCODE
.S ^TMP("OCXCMP",$J,"A CODE",OCXCOD0)=OCXEL
.S ^TMP("OCXCMP",$J,"A CODE","B",OCXEL,OCXCOD0)=""
;
Q OCXWARN
;
PURGE(CODE) ;
;
N D0,D1
;
S D0=0 F S D0=$O(CODE(D0)) Q:'D0 D
.I (CODE(D0)="||NOOP||") K CODE(D0) Q
.S:'$D(CODE(D0,"OPLIST")) CODE(D0,"OPLIST")=$E(CODE(D0),1)
.S D1=D0 F S D1=$O(CODE(D1)) Q:'D1 D
..Q:(CODE(D0)["OCXBOOLV")
..I (CODE(D0)=CODE(D1)) K CODE(D1)
D REINDEX(.CODE)
Q
;
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) ;
;
N TEMP,NDX1,NDX2 M TEMP=ARRAY K ARRAY
S (NDX1,NDX2)="" F S NDX1=$O(TEMP(NDX1)) Q:'$L(NDX1) 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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMP2 9635 printed Dec 13, 2024@02:24:39 Page 2
OCXOCMP2 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Compile Rule Element Evaluation Code) ;3/20/01 16:12
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
EN() ;
+1 ;
+2 if $GET(OCXWARN)
QUIT OCXWARN
+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 OCXD0,OCXD1,OCXREC,OCXDFC,OCXCF,OCXCNT1,OCXCNT2,OCXFCODE,OCXDFL,OCXSCAN,OCXSORT
+6 SET (OCXFCODE,OCXDFL)=""
+7 KILL OCXREC
MERGE OCXREC=^OCXS(860.3,OCXEL)
if '$DATA(OCXREC(0))
QUIT
+8 SET OCXNAM=$PIECE(OCXREC(0),U,1)
if '$LENGTH(OCXNAM)
QUIT
+9 SET OCXCON=$PIECE(OCXREC(0),U,2)
IF '(OCXCON)
DO WARN^OCXOCMPV("Context not defined for Element...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+10 if (OCXCON=OCXDLK)
QUIT
+11 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
+12 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
+13 ;
+14 IF (OCXCONN="TIMED ORDER CHECK")
Begin DoDot:2
+15 DO FILECODE("I ($G(OCXOSRC)="""_OCXCONN_"""),($D(OCXOSRC(""ELEMENT"","_OCXEL_")))","Y")
End DoDot:2
IF 1
+16 IF '$TEST
DO FILECODE("I ($G(OCXOSRC)="""_OCXCONN_""")","Y")
+17 ;
+18 IF '$GET(OCXAUTO)
if ($X>60)
WRITE !
WRITE "."
+19 KILL OCXSORT
+20 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXREC("COND",OCXD1))
if 'OCXD1
QUIT
Begin DoDot:2
+21 NEW OCXSUB
+22 FOR OCXSUB=1,2,3
Begin DoDot:3
+23 NEW OCXDF,OCXFREC,OCXCNT
+24 SET OCXDF=+$GET(OCXREC("COND",OCXD1,"DFLD"_OCXSUB))
if 'OCXDF
QUIT
+25 KILL OCXFREC
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF)
+26 SET OCXCNT=+$GET(OCXFREC)
+27 IF '$DATA(OCXFREC(OCXCON))
SET OCXCNT=OCXCNT+99999
IF '$DATA(OCXFREC(OCXDLK))
Begin DoDot:4
+28 DO WARN^OCXOCMPV("Cannot resolve Navigation code for Data Field "_OCXCONN_" context...",4,OCXDF,$PIECE($TEXT(+1)," ",1))
QUIT
End DoDot:4
QUIT
+29 SET OCXSORT(OCXD1)=$GET(OCXSORT(OCXD1))+OCXCNT
+30 SET OCXSORT(OCXD1,OCXCNT,OCXDF)=""
End DoDot:3
if OCXWARN
QUIT
End DoDot:2
if OCXWARN
QUIT
+31 ;
+32 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXSORT(OCXD1))
if 'OCXD1
QUIT
SET OCXSORT("A",OCXSORT(OCXD1),OCXD1)=""
+33 ;
+34 if OCXWARN
QUIT
+35 ;
+36 ; GET PRIMARY DATA FIELD'S 'GET CODE'
+37 ;
+38 SET OCXCNT1=0
FOR
SET OCXCNT1=$ORDER(OCXSORT("A",OCXCNT1))
if 'OCXCNT1
QUIT
Begin DoDot:2
+39 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXSORT("A",OCXCNT1,OCXD1))
if 'OCXD1
QUIT
Begin DoDot:3
+40 NEW OCXDF,OCXD2,OCXFREC
KILL OCXFREC
+41 SET OCXCNT2=0
FOR
SET OCXCNT2=$ORDER(OCXSORT(OCXD1,OCXCNT2))
if 'OCXCNT2
QUIT
Begin DoDot:4
+42 SET OCXDF=0
FOR
SET OCXDF=$ORDER(OCXSORT(OCXD1,OCXCNT2,OCXDF))
if 'OCXDF
QUIT
Begin DoDot:5
+43 IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXCON))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXCON)
+44 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
+45 SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFREC(OCXD2))
if 'OCXD2
QUIT
DO FILECODE($GET(OCXFREC(OCXD2)))
End DoDot:5
if OCXWARN
QUIT
End DoDot:4
if OCXWARN
QUIT
+46 ;
+47 ; GET EXPRESSION CONDITIONAL EVALUATION CODE
+48 ;
+49 if '$DATA(OCXFREC)
QUIT
+50 NEW OCXCOD1,OCXCOD2,OCXCVAL,OCXFLDG,OCXFLDN,OCXFLDP,OCXFLDS,OCXDFLD
+51 NEW OCXNAM,OCXOPER,OCXOPC,OCXD2,OCXD3,OCXP,OCXP1,OCXP2,OCXP3
+52 SET OCXOPER=$GET(OCXREC("COND",OCXD1,"OPER"))
+53 IF '(OCXOPER)
DO WARN^OCXOCMPV("Operator/Function not defined...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+54 SET OCXOPN=$PIECE($GET(^OCXS(863.9,OCXOPER,0)),U,1)
SET OCXOPDT=$PIECE($GET(^OCXS(863.9,OCXOPER,0)),U,2)
+55 IF '(OCXOPDT)
DO WARN^OCXOCMPV("Data Type not defined for '"_OCXOPN_"' Operator",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+56 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
+57 SET OCXOPC=$$GETPARM^OCXOCMPE(39,OCXOPER,"OCXO GENERATE CODE FUNCTION")
+58 IF '$LENGTH(OCXOPC)
DO WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' parameter not defined",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+59 if '(OCXOPC=+OCXOPC)
SET OCXOPC=$$GETIEN("^OCXS(863.7)",OCXOPC)
+60 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
+61 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
+62 SET OCXD2=0
FOR
SET OCXD2=$ORDER(^OCXS(863.7,+OCXOPC,"PAR",OCXD2))
if 'OCXD2
QUIT
Begin DoDot:4
+63 NEW OCXPOS,OCXVNAM
+64 SET OCXPOS=+$GET(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,"IN"))
if 'OCXPOS
QUIT
if $DATA(OCXP(OCXPOS))
QUIT
+65 SET OCXVNAM=+$GET(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,0))
if 'OCXVNAM
QUIT
+66 SET OCXVNAM=$PIECE($GET(^OCXS(863.8,+OCXVNAM,0)),U,2)
if '$LENGTH(OCXVNAM)
QUIT
+67 SET OCXP(+OCXPOS)=OCXVNAM
SET OCXP(OCXVNAM)=""
+68 ;
End DoDot:4
+69 DO GETC^OCXOCMPE(OCXEL,OCXD1,.OCXP)
End DoDot:3
if OCXWARN
QUIT
End DoDot:2
+70 ;
+71 ; GATHER OUTPUT DATA FOR THIS ELEMENT-EVENT
+72 ;
+73 SET OCXDF=0
FOR
SET OCXDF=$ORDER(^TMP("OCXCMP",$JOB,"ELEMENT",OCXEL,"DATA",OCXDF))
if 'OCXDF
QUIT
Begin DoDot:2
+74 NEW OCXCON,OCXFREC
SET OCXCON=$PIECE($GET(^OCXS(860.3,OCXEL,0)),U,2)
+75 IF 'OCXCON
DO WARN^OCXOCMPV("CMP2 Data context not defined for '"_$PIECE($GET(^OCXS(860.3,+OCXEL,0)),U,1)_"' ( "_(+OCXDF)_" )",2,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+76 IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXCON))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXCON)
+77 IF '$TEST
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXDF,OCXDLK)
+78 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
+79 SET OCXDFL(OCXDF)=+$GET(^TMP("OCXCMP",$JOB,"ELEMENT",OCXEL,"DATA",OCXDF))
+80 SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFREC(OCXD2))
if 'OCXD2
QUIT
IF $LENGTH($GET(OCXFREC(OCXD2)))
Begin DoDot:3
+81 DO FILECODE(OCXFREC(OCXD2),$GET(OCXFREC(OCXD2,"OPLIST")))
End DoDot:3
+82 ;
End DoDot:2
+83 ;
+84 ; FILE ELEMENT-EVENT IN ACTIVE PATIENT DATA FILE
+85 ;
+86 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:"")
+87 ;
+88 IF OCXTLOG
Begin DoDot:2
+89 NEW OCXX,OPCODE
+90 SET OCXX="S OCXOERR=$$TIMELOG(""O"",""FILE"")"
+91 SET OCXX=OCXX_",OCXOERR=$$FILE(DFN,"_OCXEL_","""_OCXDFL_""")"
+92 SET OCXX=OCXX_",OCXOERR=$$TIMELOG(""I"",""FILE"")"
+93 DO FILECODE(OCXX,"SHS")
End DoDot:2
+94 IF 'OCXTLOG
DO FILECODE("S OCXOERR=$$FILE(DFN,"_OCXEL_","""_OCXDFL_""") Q:OCXOERR ","SQ")
+95 ;
+96 ; RESOLVE EXTRINSIC FUNCTON RUNTIME PARAMETERS
+97 ;
+98 SET OCXSCAN=0
FOR
Begin DoDot:2
+99 SET OCXSCAN=0
SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFCODE(OCXD2))
if 'OCXD2
QUIT
IF $LENGTH(OCXFCODE(OCXD2))
IF (OCXFCODE(OCXD2)["|")
Begin DoDot:3
+100 NEW OCXPIEC,DFNAM,DFNUM,DFCODE
+101 SET DFCODE=OCXFCODE(OCXD2)
+102 FOR OCXPIEC=2:2:$LENGTH(DFCODE,"|")
SET DFNAM=$PIECE($PIECE(DFCODE,"|",OCXPIEC),"|",1)
IF $LENGTH(DFNAM)
IF '(DFNAM["""")
SET DFNAM(DFNAM)=""
+103 SET DFNAM=""
FOR
SET DFNAM=$ORDER(DFNAM(DFNAM))
if '$LENGTH(DFNAM)
QUIT
Begin DoDot:4
+104 NEW DFBNAM,DFNUM,OCXFREC,OCXD3
+105 SET DFBNAM="|"_DFNAM_"|"
SET OCXSCAN=1
+106 SET DFNUM=+$ORDER(^OCXS(860.4,"B",DFNAM,0))
+107 IF 'DFNUM
SET DFNUM=+$ORDER(^OCXS(860.4,"C",DFNAM,0))
+108 IF 'DFNUM
DO WARN^OCXOCMPV("Data field argument '"_DFNAM_"' not defined in Data Field file...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+109 IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXCON))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXCON)
+110 IF '$TEST
IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXDLK))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",DFNUM,OCXDLK)
+111 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
+112 IF '$DATA(OCXFREC)
DO WARN^OCXOCMPV("Data field '"_DFNAM_"' get code not defined for '"_OCXCONN_" context...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT
+113 SET OCXFREC($ORDER(OCXFREC(99999),-1)+1)="I $L(OCXDF("_(+DFNUM)_"))"
+114 SET OCXD3=0
FOR
SET OCXD3=$ORDER(OCXFREC(OCXD3))
if 'OCXD3
QUIT
DO FILECODE($GET(OCXFREC(OCXD3)),$GET(OCXFREC(OCXD3,"OPLIST")),OCXD2)
+115 FOR
if '(DFCODE[DFBNAM)
QUIT
SET DFCODE=$PIECE(DFCODE,DFBNAM,1)_"OCXDF("_(+DFNUM)_")"_$PIECE(DFCODE,DFBNAM,2,999)
End DoDot:4
+116 SET OCXFCODE(OCXD2)=DFCODE
End DoDot:3
+117 ;
+118 ; PURGE REDUNDANT CODE
+119 ;
+120 DO PURGE(.OCXFCODE)
End DoDot:2
if 'OCXSCAN
QUIT
if OCXWARN
QUIT
+121 ;
+122 IF (OCXTLOG)
SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXFCODE(OCXD2))
if 'OCXD2
QUIT
IF (OCXFCODE(OCXD2)["$$")
IF '(OCXFCODE(OCXD2)["$$TIMELOG")
Begin DoDot:2
+123 NEW OCXX,OPCODE
+124 SET OPCODE=$EXTRACT(OCXFCODE(OCXD2),1)
+125 SET OCXX="S OCXOERR=$$TIMELOG(""O"","""_$PIECE($PIECE(OCXFCODE(OCXD2),"$$",2)_"(","(",1)_""")"
+126 SET OCXX=OCXX_" "_OCXFCODE(OCXD2)
+127 SET OCXX=OCXX_" S OCXOERR=$$TIMELOG(""I"","""_$PIECE($PIECE(OCXFCODE(OCXD2),"$$",2)_"(","(",1)_""")"
+128 SET OCXFCODE(OCXD2)=OCXX
+129 SET OCXFCODE(OCXD2,"OPLIST")="SH"_OPCODE_"S"
End DoDot:2
+130 ;
+131 ;
+132 ; PURGE AND REINDEX CODE
+133 ;
+134 DO PURGE(.OCXFCODE)
+135 ;
+136 ; SAVE CODE IN ^TMP GLOBAL
+137 ;
+138 SET OCXCOD0=$ORDER(^TMP("OCXCMP",$JOB,"A CODE",99999),-1)+1
+139 ;
+140 MERGE ^TMP("OCXCMP",$JOB,"A CODE",OCXCOD0)=OCXFCODE
+141 SET ^TMP("OCXCMP",$JOB,"A CODE",OCXCOD0)=OCXEL
+142 SET ^TMP("OCXCMP",$JOB,"A CODE","B",OCXEL,OCXCOD0)=""
End DoDot:1
if OCXWARN
QUIT
+143 ;
+144 QUIT OCXWARN
+145 ;
PURGE(CODE) ;
+1 ;
+2 NEW D0,D1
+3 ;
+4 SET D0=0
FOR
SET D0=$ORDER(CODE(D0))
if 'D0
QUIT
Begin DoDot:1
+5 IF (CODE(D0)="||NOOP||")
KILL CODE(D0)
QUIT
+6 if '$DATA(CODE(D0,"OPLIST"))
SET CODE(D0,"OPLIST")=$EXTRACT(CODE(D0),1)
+7 SET D1=D0
FOR
SET D1=$ORDER(CODE(D1))
if 'D1
QUIT
Begin DoDot:2
+8 if (CODE(D0)["OCXBOOLV")
QUIT
+9 IF (CODE(D0)=CODE(D1))
KILL CODE(D1)
End DoDot:2
End DoDot:1
+10 DO REINDEX(.CODE)
+11 QUIT
+12 ;
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 IF IEN1
IF IEN2
QUIT -1
+8 QUIT IEN1
+9 ;
REINDEX(ARRAY) ;
+1 ;
+2 NEW TEMP,NDX1,NDX2
MERGE TEMP=ARRAY
KILL ARRAY
+3 SET (NDX1,NDX2)=""
FOR
SET NDX1=$ORDER(TEMP(NDX1))
if '$LENGTH(NDX1)
QUIT
IF $LENGTH(TEMP(NDX1))
SET NDX2=NDX2+1
MERGE ARRAY(NDX2)=TEMP(NDX1)
+4 QUIT
+5 ;
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 ;
