- 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 Apr 23, 2025@18:54:35 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 ;
