Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLROTSCH

BLROTSCH.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1. EP ; EP
  1. PEP ; EP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D BLR2VARS
  1.  ;
  1.  D ADDTMENU^BLRGMENU("LROSREPL^BLROTSCH","Order/Test Status Replacement")
  1.  D ADDTMENU^BLRGMENU("LROSREST^BLROTSCH","Order/Test Status Restore")
  1.  ;
  1.  D MENUDRVR^BLRGMENU("RPMS Lab","Order/Test Status Utilities")
  1.  Q
  1.  ;
  1. 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)
  1.  ;
  1.  Q:$$CHKOVERR("BLRLROS")="Q"
  1.  ;
  1.  D BLR2VARS("LROSREPL")
  1.  ;
  1.  S HEADER(1)="Order/Test Status Replacement"
  1.  S HEADER(2)="With the RPMS version"
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  ;     123456789012345678901234567890123456789012345678901234567890
  1.  W ?9,"This routine will replace the current Order/Test Status routine",!
  1.  W ?4,"(LROS) with the RPMS routine (BLRLROS).",!!
  1.  W ?9,"The RPMS version displays the SNOMED, UID, Clinical Indication",!
  1.  W ?4,"as well as the order's ICD code(s).",!
  1.  ;
  1.  Q:$$WARNINGS("Are you sure you want to do this",9)="Q"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  Q:$$WARNINGS("Second Chance: Are you still sure you want to do this",9)="Q"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  Q:$$WARNINGS("LAST CHANCE: Do you want to do this",9)="Q"
  1.  ;
  1.  W !!,?4,"Very well."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  I $D(^ROUTINE("LROSORIG"))<1 D
  1.  . D HEADERDT^BLRGMENU
  1.  . S X=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"L")
  1.  . S RETURN=$$ROUTINE^%R("LROSORIG.INT",.CODE,.ERRORS,"BCS")
  1.  . I +$G(RETURN)<1 D  Q
  1.  .. W ?4,"LROS could *NOT* be saved as LROSORIG.  Error Message follows:",!
  1.  .. W $$FMTERR^%R(.ERRORS,.CODE),!
  1.  .. W ?4,"Routine Ends."
  1.  .. D PRESSKEY^BLRGMENU(9)
  1.  .. S BADSTUFF="YES"
  1.  . ;
  1.  . W ?4,"LROS has successfully been saved as LROSORIG"
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  Q:$G(BADSTUFF)="YES"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  S X=$$ROUTINE^%R("BLRLROS.INT",.CODE,.ERRORS,"L")
  1.  S RETURN=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"BCS")
  1.  ;
  1.  I +$G(RETURN)<1 D  Q
  1.  . W ?4,"BLRLROS could *NOT* overwrite LROS.  Error Message follows:",!
  1.  . W $$FMTERR^%R(.ERRORS,.CODE),!
  1.  . W ?4,"Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  W ?4,"BLRLROS has successfully overwritten LROS."
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. 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)
  1.  ;
  1.  Q:$$CHKOVERR("LROSORIG")="Q"
  1.  ;
  1.  D BLR2VARS("LROSREPL")
  1.  ;
  1.  S HEADER(1)="Order/Test Status Replacement"
  1.  S HEADER(2)="With the Original VistA version"
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  ;     123456789012345678901234567890123456789012345678901234567890
  1.  W ?9,"This routine will replace the current Order/Test Status",!
  1.  W ?4,"routine with the original VistA version from the VA.",!!
  1.  W ?9,"The VistA version does *NOT* display the order's: SNOMED",!
  1.  W ?4," code; UID; nor ICD code(s).",!
  1.  ;
  1.  Q:$$WARNINGS("Are you sure you want to do this",9)="Q"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  Q:$$WARNINGS("Second Chance: Are you still sure you want to do this",9)="Q"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  Q:$$WARNINGS("LAST CHANCE: Do you want to do this",9)="Q"
  1.  ;
  1.  W !!,?4,"Very well."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  S X=$$ROUTINE^%R("LROSORIG.INT",.CODE,.ERRORS,"L")
  1.  S RETURN=$$ROUTINE^%R("LROS.INT",.CODE,.ERRORS,"BCS")
  1.  ;
  1.  I +$G(RETURN)<1 D  Q
  1.  . W ?4,"Original Vista version could *NOT* overwrite.  Error Message follows:",!
  1.  . W $$FMTERR^%R(.ERRORS,.CODE),!
  1.  . W ?4,"Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  ;     567890123456789012345678901234567890123456789012345678901234567890
  1.  W ?4,"The original VistA version has successfully overwritten the current",!
  1.  W ?4,"Order/Test status report."
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. CHKOVERR(RTN) ; EP - CHecK to make sure OVERwrite Routine exists
  1.  I $D(^ROUTINE(RTN))<1 D  Q "Q"
  1.  . W !!,?4,"The routine ",RTN," does NOT exist on this server."
  1.  . W !!,?9,"Please contact IHS/OIT Lab Support."
  1.  . D PRESSKEY^BLRGMENU(14)
  1.  Q "OK"
  1.  ;
  1.  ; ============================= UTILITIES =============================
  1.  ;
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q
  1.  ;
  1. BLR2VARS(TWO) ; EP
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S:$L($G(TWO)) BLRVERN2=TWO
  1.  Q
  1.  ;
  1. WARNINGS(MSG,TAB) ; EP
  1.  S TAB=$S(+$G(TAB):TAB,1:4)
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("A")=$J("",TAB)_MSG
  1.  S DIR("B")="NO"
  1.  D ^DIR
  1.  Q:+$G(Y)<1!(+$D(DIRUT)) "Q"
  1.  ;
  1.  Q "OK"
  1.  ;
  1. BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
  1.  S TAB=$S($L($G(TAB))<1:4,1:TAB)
  1.  W !!,?TAB,STR,"  Routine Ends."
  1.  D PRESSKEY^BLRGMENU(TAB+5)
  1.  Q
  1.  ;
  1. BADSTUFN(STR,TAB) ; EP - BADSTUFF error message.  Ends with Q "" (i.e., null)
  1.  D BADSTUFF(STR,$G(TAB))
  1.  Q ""
  1.  ;
  1. BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message.  Ends with Q "Q"uit
  1.  D BADSTUFF(STR,$G(TAB))
  1.  Q "Q"
  1.  ;