- 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 Feb 18, 2025@23:51:12 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 ;