BLROTSCH ; IHS/OIT/MKK - IHS LAB Order Test/Status CHanger; 10-Mar-2015 10:22 ; MKK
;;5.2;IHS Laboratory;**1034**;NOV 01, 1997;Build 88
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
EP ; EP
PEP ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D BLR2VARS
;
D ADDTMENU^BLRGMENU("LROSREPL^BLROTSCH","Order/Test Status Replacement")
D ADDTMENU^BLRGMENU("LROSREST^BLROTSCH","Order/Test Status Restore")
;
D MENUDRVR^BLRGMENU("RPMS Lab","Order/Test Status Utilities")
Q
;
LROSREPL ; EP - LROS routine REPLacement
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$$CHKOVERR("BLRLROS")="Q"
;
D BLR2VARS("LROSREPL")
;
S HEADER(1)="Order/Test Status Replacement"
S HEADER(2)="With the RPMS version"
D HEADERDT^BLRGMENU
;
; 123456789012345678901234567890123456789012345678901234567890
W ?9,"This routine will replace the current Order/Test Status routine",!
W ?4,"(LROS) with the RPMS routine (BLRLROS).",!!
W ?9,"The RPMS version displays the SNOMED, UID, Clinical Indication",!
W ?4,"as well as the order's ICD code(s).",!
;
Q:$$WARNINGS("Are you sure you want to do this",9)="Q"
;
D HEADERDT^BLRGMENU
Q:$$WARNINGS("Second Chance: Are you still sure you want to do this",9)="Q"
;
D HEADERDT^BLRGMENU
Q:$$WARNINGS("LAST CHANCE: Do you want to do this",9)="Q"
;
W !!,?4,"Very well."
D PRESSKEY^BLRGMENU(9)
;
I $D(^ROUTINE("LROSORIG"))<1 D
. D HEADERDT^BLRGMENU
. S X=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"L")
. S RETURN=$$ROUTINE^%R("LROSORIG.INT",.CODE,.ERRORS,"BCS")
. I +$G(RETURN)<1 D Q
.. W ?4,"LROS could *NOT* be saved as LROSORIG. Error Message follows:",!
.. W $$FMTERR^%R(.ERRORS,.CODE),!
.. W ?4,"Routine Ends."
.. D PRESSKEY^BLRGMENU(9)
.. S BADSTUFF="YES"
. ;
. W ?4,"LROS has successfully been saved as LROSORIG"
. D PRESSKEY^BLRGMENU(9)
;
Q:$G(BADSTUFF)="YES"
;
D HEADERDT^BLRGMENU
;
S X=$$ROUTINE^%R("BLRLROS.INT",.CODE,.ERRORS,"L")
S RETURN=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"BCS")
;
I +$G(RETURN)<1 D Q
. W ?4,"BLRLROS could *NOT* overwrite LROS. Error Message follows:",!
. W $$FMTERR^%R(.ERRORS,.CODE),!
. W ?4,"Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
W ?4,"BLRLROS has successfully overwritten LROS."
;
D PRESSKEY^BLRGMENU(9)
Q
;
LROSREST ; EP - LROS routine RESTore
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$$CHKOVERR("LROSORIG")="Q"
;
D BLR2VARS("LROSREPL")
;
S HEADER(1)="Order/Test Status Replacement"
S HEADER(2)="With the Original VistA version"
D HEADERDT^BLRGMENU
;
; 123456789012345678901234567890123456789012345678901234567890
W ?9,"This routine will replace the current Order/Test Status",!
W ?4,"routine with the original VistA version from the VA.",!!
W ?9,"The VistA version does *NOT* display the order's: SNOMED",!
W ?4," code; UID; nor ICD code(s).",!
;
Q:$$WARNINGS("Are you sure you want to do this",9)="Q"
;
D HEADERDT^BLRGMENU
Q:$$WARNINGS("Second Chance: Are you still sure you want to do this",9)="Q"
;
D HEADERDT^BLRGMENU
Q:$$WARNINGS("LAST CHANCE: Do you want to do this",9)="Q"
;
W !!,?4,"Very well."
D PRESSKEY^BLRGMENU(9)
;
D HEADERDT^BLRGMENU
;
S X=$$ROUTINE^%R("LROSORIG.INT",.CODE,.ERRORS,"L")
S RETURN=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"BCS")
;
I +$G(RETURN)<1 D Q
. W ?4,"Original Vista version could *NOT* overwrite. Error Message follows:",!
. W $$FMTERR^%R(.ERRORS,.CODE),!
. W ?4,"Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
; 567890123456789012345678901234567890123456789012345678901234567890
W ?4,"The original VistA version has successfully overwritten the current",!
W ?4,"Order/Test status report."
;
D PRESSKEY^BLRGMENU(9)
Q
;
CHKOVERR(RTN) ; EP - CHecK to make sure OVERwrite Routine exists
I $D(^ROUTINE(RTN))<1 D Q "Q"
. W !!,?4,"The routine ",RTN," does NOT exist on this server."
. W !!,?9,"Please contact IHS/OIT Lab Support."
. D PRESSKEY^BLRGMENU(14)
Q "OK"
;
; ============================= UTILITIES =============================
;
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q
;
BLR2VARS(TWO) ; EP
S BLRVERN=$TR($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=TWO
Q
;
WARNINGS(MSG,TAB) ; EP
S TAB=$S(+$G(TAB):TAB,1:4)
D ^XBFMK
S DIR(0)="YO"
S DIR("A")=$J("",TAB)_MSG
S DIR("B")="NO"
D ^DIR
Q:+$G(Y)<1!(+$D(DIRUT)) "Q"
;
Q "OK"
;
BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
S TAB=$S($L($G(TAB))<1:4,1:TAB)
W !!,?TAB,STR," Routine Ends."
D PRESSKEY^BLRGMENU(TAB+5)
Q
;
BADSTUFN(STR,TAB) ; EP - BADSTUFF error message. Ends with Q "" (i.e., null)
D BADSTUFF(STR,$G(TAB))
Q ""
;
BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message. Ends with Q "Q"uit
D BADSTUFF(STR,$G(TAB))
Q "Q"
;
BLROTSCH ; IHS/OIT/MKK - IHS LAB Order Test/Status CHanger; 10-Mar-2015 10:22 ; MKK
+1 ;;5.2;IHS Laboratory;**1034**;NOV 01, 1997;Build 88
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
EP ; EP
PEP ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO BLR2VARS
+4 ;
+5 DO ADDTMENU^BLRGMENU("LROSREPL^BLROTSCH","Order/Test Status Replacement")
+6 DO ADDTMENU^BLRGMENU("LROSREST^BLROTSCH","Order/Test Status Restore")
+7 ;
+8 DO MENUDRVR^BLRGMENU("RPMS Lab","Order/Test Status Utilities")
+9 QUIT
+10 ;
LROSREPL ; EP - LROS routine REPLacement
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$CHKOVERR("BLRLROS")="Q"
QUIT
+4 ;
+5 DO BLR2VARS("LROSREPL")
+6 ;
+7 SET HEADER(1)="Order/Test Status Replacement"
+8 SET HEADER(2)="With the RPMS version"
+9 DO HEADERDT^BLRGMENU
+10 ;
+11 ; 123456789012345678901234567890123456789012345678901234567890
+12 WRITE ?9,"This routine will replace the current Order/Test Status routine",!
+13 WRITE ?4,"(LROS) with the RPMS routine (BLRLROS).",!!
+14 WRITE ?9,"The RPMS version displays the SNOMED, UID, Clinical Indication",!
+15 WRITE ?4,"as well as the order's ICD code(s).",!
+16 ;
+17 IF $$WARNINGS("Are you sure you want to do this",9)="Q"
QUIT
+18 ;
+19 DO HEADERDT^BLRGMENU
+20 IF $$WARNINGS("Second Chance
QUIT
+21 ;
+22 DO HEADERDT^BLRGMENU
+23 IF $$WARNINGS("LAST CHANCE
QUIT
+24 ;
+25 WRITE !!,?4,"Very well."
+26 DO PRESSKEY^BLRGMENU(9)
+27 ;
+28 IF $DATA(^ROUTINE("LROSORIG"))<1
Begin DoDot:1
+29 DO HEADERDT^BLRGMENU
+30 SET X=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"L")
+31 SET RETURN=$$ROUTINE^%R("LROSORIG.INT",.CODE,.ERRORS,"BCS")
+32 IF +$GET(RETURN)<1
Begin DoDot:2
+33 WRITE ?4,"LROS could *NOT* be saved as LROSORIG. Error Message follows:",!
+34 WRITE $$FMTERR^%R(.ERRORS,.CODE),!
+35 WRITE ?4,"Routine Ends."
+36 DO PRESSKEY^BLRGMENU(9)
+37 SET BADSTUFF="YES"
End DoDot:2
QUIT
+38 ;
+39 WRITE ?4,"LROS has successfully been saved as LROSORIG"
+40 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
+41 ;
+42 IF $GET(BADSTUFF)="YES"
QUIT
+43 ;
+44 DO HEADERDT^BLRGMENU
+45 ;
+46 SET X=$$ROUTINE^%R("BLRLROS.INT",.CODE,.ERRORS,"L")
+47 SET RETURN=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"BCS")
+48 ;
+49 IF +$GET(RETURN)<1
Begin DoDot:1
+50 WRITE ?4,"BLRLROS could *NOT* overwrite LROS. Error Message follows:",!
+51 WRITE $$FMTERR^%R(.ERRORS,.CODE),!
+52 WRITE ?4,"Routine Ends."
+53 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+54 ;
+55 WRITE ?4,"BLRLROS has successfully overwritten LROS."
+56 ;
+57 DO PRESSKEY^BLRGMENU(9)
+58 QUIT
+59 ;
LROSREST ; EP - LROS routine RESTore
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$CHKOVERR("LROSORIG")="Q"
QUIT
+4 ;
+5 DO BLR2VARS("LROSREPL")
+6 ;
+7 SET HEADER(1)="Order/Test Status Replacement"
+8 SET HEADER(2)="With the Original VistA version"
+9 DO HEADERDT^BLRGMENU
+10 ;
+11 ; 123456789012345678901234567890123456789012345678901234567890
+12 WRITE ?9,"This routine will replace the current Order/Test Status",!
+13 WRITE ?4,"routine with the original VistA version from the VA.",!!
+14 WRITE ?9,"The VistA version does *NOT* display the order's: SNOMED",!
+15 WRITE ?4," code; UID; nor ICD code(s).",!
+16 ;
+17 IF $$WARNINGS("Are you sure you want to do this",9)="Q"
QUIT
+18 ;
+19 DO HEADERDT^BLRGMENU
+20 IF $$WARNINGS("Second Chance
QUIT
+21 ;
+22 DO HEADERDT^BLRGMENU
+23 IF $$WARNINGS("LAST CHANCE
QUIT
+24 ;
+25 WRITE !!,?4,"Very well."
+26 DO PRESSKEY^BLRGMENU(9)
+27 ;
+28 DO HEADERDT^BLRGMENU
+29 ;
+30 SET X=$$ROUTINE^%R("LROSORIG.INT",.CODE,.ERRORS,"L")
+31 SET RETURN=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"BCS")
+32 ;
+33 IF +$GET(RETURN)<1
Begin DoDot:1
+34 WRITE ?4,"Original Vista version could *NOT* overwrite. Error Message follows:",!
+35 WRITE $$FMTERR^%R(.ERRORS,.CODE),!
+36 WRITE ?4,"Routine Ends."
+37 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+38 ;
+39 ; 567890123456789012345678901234567890123456789012345678901234567890
+40 WRITE ?4,"The original VistA version has successfully overwritten the current",!
+41 WRITE ?4,"Order/Test status report."
+42 ;
+43 DO PRESSKEY^BLRGMENU(9)
+44 QUIT
+45 ;
CHKOVERR(RTN) ; EP - CHecK to make sure OVERwrite Routine exists
+1 IF $DATA(^ROUTINE(RTN))<1
Begin DoDot:1
+2 WRITE !!,?4,"The routine ",RTN," does NOT exist on this server."
+3 WRITE !!,?9,"Please contact IHS/OIT Lab Support."
+4 DO PRESSKEY^BLRGMENU(14)
End DoDot:1
QUIT "Q"
+5 QUIT "OK"
+6 ;
+7 ; ============================= UTILITIES =============================
+8 ;
+9 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+10 ;
+11 QUIT
+12 ;
BLR2VARS(TWO) ; EP
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 IF $LENGTH($GET(TWO))
SET BLRVERN2=TWO
+3 QUIT
+4 ;
WARNINGS(MSG,TAB) ; EP
+1 SET TAB=$SELECT(+$GET(TAB):TAB,1:4)
+2 DO ^XBFMK
+3 SET DIR(0)="YO"
+4 SET DIR("A")=$JUSTIFY("",TAB)_MSG
+5 SET DIR("B")="NO"
+6 DO ^DIR
+7 IF +$GET(Y)<1!(+$DATA(DIRUT))
QUIT "Q"
+8 ;
+9 QUIT "OK"
+10 ;
BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
+1 SET TAB=$SELECT($LENGTH($GET(TAB))<1:4,1:TAB)
+2 WRITE !!,?TAB,STR," Routine Ends."
+3 DO PRESSKEY^BLRGMENU(TAB+5)
+4 QUIT
+5 ;
BADSTUFN(STR,TAB) ; EP - BADSTUFF error message. Ends with Q "" (i.e., null)
+1 DO BADSTUFF(STR,$GET(TAB))
+2 QUIT ""
+3 ;
BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message. Ends with Q "Q"uit
+1 DO BADSTUFF(STR,$GET(TAB))
+2 QUIT "Q"
+3 ;
