ORY26508 ;SLC/JEH - OCX PACKAGE RULE TRANSPORT ROUTINE - PLUS ;NOV 16, 2006 15:00
;;3.0;ORDER ENTRY/RESULTS REPORTING;**265**;Dec 17,1997;Build 17
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;; ;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
SCH ; This code will correct the pointer to imaging.
N DTIME,DLAYGO,DINUM,DIC,Y,X,IX,OLD,RPTID,DONEX
S DIC="^ORD(100.98," ; Find the IEN of IMAGING in the Display File
S DIC(0)="N,O,X"
S X="IMAGING"
D ^DIC
I $G(Y) D ; RPT SCHEDULED/DUE ACTIVITY replace IEN for NURSING (13) (found at some sites) with IMAGING IEN
. S X=+Y
. ;
. S (IX,DONEX,RPTID,OLD)=0
. S RPTID=$O(^ORD(102.21,"B","RPT SCHEDULED/DUE ACTIVITY",0))
. F S IX=$O(^ORD(102.21,RPTID,1,IX)) Q:('IX)!DONEX D
. . I $P(^ORD(102.21,RPTID,1,IX,0),U,4)="IMAGING" D
. . . I ^ORD(102.21,RPTID,1,IX,1,1,0)'=X D
. . . . S OLD=^ORD(102.21,RPTID,1,IX,1,1,0)
. . . . S ^ORD(102.21,RPTID,1,IX,1,1,0)=X
. . . . K ^ORD(102.21,RPTID,1,IX,1,"B",OLD,1)
. . . . S ^ORD(102.21,RPTID,1,IX,1,"B",X,1)="",DONEX=1
W !,"FINISHED: UPDATING CPRS QUERY DEFINITION NAME / RPT SCHEDULED/DUE ACTIVITY"
W !
;
OCX ; this code updates the expert system to compile code that allows results with "<>=" in matching the threshold limit.
N LINE,UPDATE,TEXT1,TEXT2,ADDTEXT,TTALCNT,CNT
S UPDATE=0
S TEXT1="",TEXT2=""
S TTALCNT=$P(^OCXS(860.8,53,"CODE",0),"^",3)+1
S LINE=1
S ADDTEXT=$P($T(DATA+1),";",3,40)
F S LINE=$O(^OCXS(860.8,53,"CODE",LINE)) Q:(LINE=TTALCNT)!(LINE="")!(LINE]"@") D
. I ^OCXS(860.8,53,"CODE",LINE,0)=ADDTEXT S TTALCNT=LINE+1 Q ; If change has already been made
. I UPDATE=0,^OCXS(860.8,53,"CODE",LINE,0)=" ; Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0" D
. . S TEXT1=^OCXS(860.8,53,"CODE",LINE,0)
. . S ^OCXS(860.8,53,"CODE",LINE,0)=$P($T(DATA+1),";",3,40)
. . S UPDATE=1
. . ; Q
. I UPDATE=1 D
. . S TEXT2=TEXT1
. . S CNT=LINE+1
. . S TEXT1=$G(^OCXS(860.8,53,"CODE",CNT,0))
. . S ^OCXS(860.8,53,"CODE",CNT,0)=TEXT2
. . Q:TEXT1=""
I UPDATE=1 D
. S $P(^OCXS(860.8,53,"CODE",0),"^",3)=TTALCNT
. S $P(^OCXS(860.8,53,"CODE",0),"^",4)=TTALCNT
. W !,"FINISHED: UPDATING ORDER CHECK COMPILER FUNCTIONS"
. W !!,"THE EXPERT SYSTEM WILL NEED TO BE RECOMPILED TO COMPLETE THIS PROCESS"
. W !,"PLEASE SEE THE PATCH INSTRUCTION ON RECOMPILING THE EXPERT SYSTEM"
I UPDATE=0 W !,"NO UPDATE NEEDED OR MADE TO EXPERT SYSTEM"
Q
;
RECOVER ; RESET TO OLD GLOBAL
N LINE,TEXT1,TTALCNT
S TEXT1=""
S TTALCNT=$P(^OCXS(860.8,53,"CODE",0),"^",3)+1
S LINE=0
F S LINE=$O(^OCXS(860.8,53,"CODE",LINE)) Q:(LINE=TTALCNT)!(LINE="")!(LINE]"@") D
. S TEXT1=$P($T(DATA2+LINE),";",3,40)
. S ^OCXS(860.8,53,"CODE",LINE,0)=TEXT1
S ^OCXS(860.8,53,"CODE",0)="^^16^16^3060823^"
Q
;
DATA ;
;; ; S OCXRSLT=$TR($G(OCXRSLT),"<>=","")
;
;;^OCXS(860.8,53,0)=LAB THRESHOLD EXCEEDED BOOLEAN^LABTHRSB
;;^OCXS(860.8,53,"CODE",0)=^^17^17^3060823^
;;^OCXS(860.8,53,"CODE",1,0)= ;LABTHRSB(OCXLAB,OCXPEC,OCXRSLT,OCXOP) ;
;;^OCXS(860.8,53,"CODE",2,0)= ; ;
;;^OCXS(860.8,53,"CODE",3,0)= ; S OCXRSLT=$TR($G(OCXRSLT),"<>=","")
;;^OCXS(860.8,53,"CODE",4,0)= ; Q:'$G(OCXLAB)!'$G(OCXPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0
;;^OCXS(860.8,53,"CODE",5,0)= ; ;
;;^OCXS(860.8,53,"CODE",6,0)= ; N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD
;;^OCXS(860.8,53,"CODE",7,0)= ; S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXPEC
;;^OCXS(860.8,53,"CODE",8,0)= ; D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR)
;;^OCXS(860.8,53,"CODE",9,0)=T+; I $G(OCXTRACE) W !,"Lab parameter values:",! ZW OCXX,OCXERR
;;^OCXS(860.8,53,"CODE",10,0)= ; Q:+$G(ORERR)'=0 OCXEXCD
;;^OCXS(860.8,53,"CODE",11,0)= ; Q:+$G(OCXX)=0 OCXEXCD
;;^OCXS(860.8,53,"CODE",12,0)= ; S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1 D
;;^OCXS(860.8,53,"CODE",13,0)= ; .S OCXPVAL=OCXX(OCXPENT,OCXLABSP)
;;^OCXS(860.8,53,"CODE",14,0)= ; .I $L(OCXPVAL) D
;;^OCXS(860.8,53,"CODE",15,0)= ; ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D
;;^OCXS(860.8,53,"CODE",16,0)= ; ...S OCXEXCD=1
;;^OCXS(860.8,53,"CODE",17,0)= ; Q OCXEXCD
;
DATA2 ;
;; ;LABTHRSB(OCXLAB,OCXPEC,OCXRSLT,OCXOP) ;
;; ; ;
;; ; Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0
;; ; ;
;; ; N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD
;; ; S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXPEC
;; ; D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR)
;;T+; I $G(OCXTRACE) W !,"Lab parameter values:",! ZW OCXX,OCXERR
;; ; Q:+$G(ORERR)'=0 OCXEXCD
;; ; Q:+$G(OCXX)=0 OCXEXCD
;; ; S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1 D
;; ; .S OCXPVAL=OCXX(OCXPENT,OCXLABSP)
;; ; .I $L(OCXPVAL) D
;; ; ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D
;; ; ...S OCXEXCD=1
;; ; Q OCXEXCD
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY26508 4908 printed Dec 13, 2024@02:40 Page 2
ORY26508 ;SLC/JEH - OCX PACKAGE RULE TRANSPORT ROUTINE - PLUS ;NOV 16, 2006 15:00
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**265**;Dec 17,1997;Build 17
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;; ;;Per VHA Directive 2004-038, this routine should not be modified.
+4 ;
+5 ;
SCH ; This code will correct the pointer to imaging.
+1 NEW DTIME,DLAYGO,DINUM,DIC,Y,X,IX,OLD,RPTID,DONEX
+2 ; Find the IEN of IMAGING in the Display File
SET DIC="^ORD(100.98,"
+3 SET DIC(0)="N,O,X"
+4 SET X="IMAGING"
+5 DO ^DIC
+6 ; RPT SCHEDULED/DUE ACTIVITY replace IEN for NURSING (13) (found at some sites) with IMAGING IEN
IF $GET(Y)
Begin DoDot:1
+7 SET X=+Y
+8 ;
+9 SET (IX,DONEX,RPTID,OLD)=0
+10 SET RPTID=$ORDER(^ORD(102.21,"B","RPT SCHEDULED/DUE ACTIVITY",0))
+11 FOR
SET IX=$ORDER(^ORD(102.21,RPTID,1,IX))
if ('IX)!DONEX
QUIT
Begin DoDot:2
+12 IF $PIECE(^ORD(102.21,RPTID,1,IX,0),U,4)="IMAGING"
Begin DoDot:3
+13 IF ^ORD(102.21,RPTID,1,IX,1,1,0)'=X
Begin DoDot:4
+14 SET OLD=^ORD(102.21,RPTID,1,IX,1,1,0)
+15 SET ^ORD(102.21,RPTID,1,IX,1,1,0)=X
+16 KILL ^ORD(102.21,RPTID,1,IX,1,"B",OLD,1)
+17 SET ^ORD(102.21,RPTID,1,IX,1,"B",X,1)=""
SET DONEX=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 WRITE !,"FINISHED: UPDATING CPRS QUERY DEFINITION NAME / RPT SCHEDULED/DUE ACTIVITY"
+19 WRITE !
+20 ;
OCX ; this code updates the expert system to compile code that allows results with "<>=" in matching the threshold limit.
+1 NEW LINE,UPDATE,TEXT1,TEXT2,ADDTEXT,TTALCNT,CNT
+2 SET UPDATE=0
+3 SET TEXT1=""
SET TEXT2=""
+4 SET TTALCNT=$PIECE(^OCXS(860.8,53,"CODE",0),"^",3)+1
+5 SET LINE=1
+6 SET ADDTEXT=$PIECE($TEXT(DATA+1),";",3,40)
+7 FOR
SET LINE=$ORDER(^OCXS(860.8,53,"CODE",LINE))
if (LINE=TTALCNT)!(LINE="")!(LINE]"@")
QUIT
Begin DoDot:1
+8 ; If change has already been made
IF ^OCXS(860.8,53,"CODE",LINE,0)=ADDTEXT
SET TTALCNT=LINE+1
QUIT
+9 IF UPDATE=0
IF ^OCXS(860.8,53,"CODE",LINE,0)=" ; Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0"
Begin DoDot:2
+10 SET TEXT1=^OCXS(860.8,53,"CODE",LINE,0)
+11 SET ^OCXS(860.8,53,"CODE",LINE,0)=$PIECE($TEXT(DATA+1),";",3,40)
+12 SET UPDATE=1
+13 ; Q
End DoDot:2
+14 IF UPDATE=1
Begin DoDot:2
+15 SET TEXT2=TEXT1
+16 SET CNT=LINE+1
+17 SET TEXT1=$GET(^OCXS(860.8,53,"CODE",CNT,0))
+18 SET ^OCXS(860.8,53,"CODE",CNT,0)=TEXT2
+19 if TEXT1=""
QUIT
End DoDot:2
End DoDot:1
+20 IF UPDATE=1
Begin DoDot:1
+21 SET $PIECE(^OCXS(860.8,53,"CODE",0),"^",3)=TTALCNT
+22 SET $PIECE(^OCXS(860.8,53,"CODE",0),"^",4)=TTALCNT
+23 WRITE !,"FINISHED: UPDATING ORDER CHECK COMPILER FUNCTIONS"
+24 WRITE !!,"THE EXPERT SYSTEM WILL NEED TO BE RECOMPILED TO COMPLETE THIS PROCESS"
+25 WRITE !,"PLEASE SEE THE PATCH INSTRUCTION ON RECOMPILING THE EXPERT SYSTEM"
End DoDot:1
+26 IF UPDATE=0
WRITE !,"NO UPDATE NEEDED OR MADE TO EXPERT SYSTEM"
+27 QUIT
+28 ;
RECOVER ; RESET TO OLD GLOBAL
+1 NEW LINE,TEXT1,TTALCNT
+2 SET TEXT1=""
+3 SET TTALCNT=$PIECE(^OCXS(860.8,53,"CODE",0),"^",3)+1
+4 SET LINE=0
+5 FOR
SET LINE=$ORDER(^OCXS(860.8,53,"CODE",LINE))
if (LINE=TTALCNT)!(LINE="")!(LINE]"@")
QUIT
Begin DoDot:1
+6 SET TEXT1=$PIECE($TEXT(DATA2+LINE),";",3,40)
+7 SET ^OCXS(860.8,53,"CODE",LINE,0)=TEXT1
End DoDot:1
+8 SET ^OCXS(860.8,53,"CODE",0)="^^16^16^3060823^"
+9 QUIT
+10 ;
DATA ;
+1 ;; ; S OCXRSLT=$TR($G(OCXRSLT),"<>=","")
+2 ;
+3 ;;^OCXS(860.8,53,0)=LAB THRESHOLD EXCEEDED BOOLEAN^LABTHRSB
+4 ;;^OCXS(860.8,53,"CODE",0)=^^17^17^3060823^
+5 ;;^OCXS(860.8,53,"CODE",1,0)= ;LABTHRSB(OCXLAB,OCXPEC,OCXRSLT,OCXOP) ;
+6 ;;^OCXS(860.8,53,"CODE",2,0)= ; ;
+7 ;;^OCXS(860.8,53,"CODE",3,0)= ; S OCXRSLT=$TR($G(OCXRSLT),"<>=","")
+8 ;;^OCXS(860.8,53,"CODE",4,0)= ; Q:'$G(OCXLAB)!'$G(OCXPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0
+9 ;;^OCXS(860.8,53,"CODE",5,0)= ; ;
+10 ;;^OCXS(860.8,53,"CODE",6,0)= ; N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD
+11 ;;^OCXS(860.8,53,"CODE",7,0)= ; S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXPEC
+12 ;;^OCXS(860.8,53,"CODE",8,0)= ; D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR)
+13 ;;^OCXS(860.8,53,"CODE",9,0)=T+; I $G(OCXTRACE) W !,"Lab parameter values:",! ZW OCXX,OCXERR
+14 ;;^OCXS(860.8,53,"CODE",10,0)= ; Q:+$G(ORERR)'=0 OCXEXCD
+15 ;;^OCXS(860.8,53,"CODE",11,0)= ; Q:+$G(OCXX)=0 OCXEXCD
+16 ;;^OCXS(860.8,53,"CODE",12,0)= ; S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1 D
+17 ;;^OCXS(860.8,53,"CODE",13,0)= ; .S OCXPVAL=OCXX(OCXPENT,OCXLABSP)
+18 ;;^OCXS(860.8,53,"CODE",14,0)= ; .I $L(OCXPVAL) D
+19 ;;^OCXS(860.8,53,"CODE",15,0)= ; ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D
+20 ;;^OCXS(860.8,53,"CODE",16,0)= ; ...S OCXEXCD=1
+21 ;;^OCXS(860.8,53,"CODE",17,0)= ; Q OCXEXCD
+22 ;
DATA2 ;
+1 ;; ;LABTHRSB(OCXLAB,OCXPEC,OCXRSLT,OCXOP) ;
+2 ;; ; ;
+3 ;; ; Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0
+4 ;; ; ;
+5 ;; ; N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD
+6 ;; ; S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXPEC
+7 ;; ; D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR)
+8 ;;T+; I $G(OCXTRACE) W !,"Lab parameter values:",! ZW OCXX,OCXERR
+9 ;; ; Q:+$G(ORERR)'=0 OCXEXCD
+10 ;; ; Q:+$G(OCXX)=0 OCXEXCD
+11 ;; ; S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1 D
+12 ;; ; .S OCXPVAL=OCXX(OCXPENT,OCXLABSP)
+13 ;; ; .I $L(OCXPVAL) D
+14 ;; ; ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D
+15 ;; ; ...S OCXEXCD=1
+16 ;; ; Q OCXEXCD
+17 ;
