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

BLRROLLD.m

Go to the documentation of this file. 
  1. BLRROLLD ; IHS/OIT/MKK - Delete anything in ROLLOVER RUNNING field in File 69.9 ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;IHS Laboratory;**1033**;NOV 01, 1997
  1.  ;
  1.  ; This routine was created to allow Laboratory personnel who do not have FileMan
  1.  ; access the ability to clear the ROLLOVER RUNNING (#521) field in the
  1.  ; LABORATORY SITE (#69.9) file.
  1.  ;
  1. EEP ; EP - Ersatz Entry
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1.  ; Delete anything in Field 521 (ROLLOVER RUNNING) field in 69.9
  1. PEP ; EP 
  1. EP ; EP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  S HEADER(1)="IHS RPMS Laboratory Module"
  1.  S HEADER(2)="LABORATORY SITE (#69.9) File"
  1.  S HEADER(3)=$$CJ^XLFSTR("ROLLOVER RUNNING (#521) field",IOM)
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  I $D(^XUSEC("LRSUPER",DUZ))<1 D  Q
  1.  . S LINE1="*** User "_$P($G(^VA(200,DUZ,0)),"^")_" [DUZ:"_DUZ_"] ***"
  1.  . S LINE2="*** does NOT have the LRSUPER Security Key. ***"
  1.  . ;
  1.  . S MAXLINE=$L(LINE1)
  1.  . I $L(LINE2)>MAXLINE D
  1.  .. S MAXLINE=$L(LINE2)
  1.  .. S LINE1=$$LJ^XLFSTR("*** User "_$P($G(^VA(200,DUZ,0)),"^")_" [DUZ:"_DUZ_"]",MAXLINE-4)_" ***"
  1.  . ;
  1.  . W !,?14,$TR($J("",MAXLINE)," ","*"),!
  1.  . W ?14,LINE1,!
  1.  . W ?14,LINE2,!
  1.  . W ?14,$$LJ^XLFSTR("*** ",MAXLINE-4)," ***",!
  1.  . W ?14,$$LJ^XLFSTR("*** Routine Ends.",MAXLINE-4)," ***",!
  1.  . W ?14,$TR($J("",MAXLINE)," ","*"),!
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  S ROLLRUNF=$$GET1^DIQ(69.9,"1,",521)
  1.  I ROLLRUNF="" D  Q
  1.  . W ?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field is Null.",!!
  1.  . W ?4,"No need to delete anything.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  W ?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field = ",ROLLRUNF,!
  1.  ;
  1.  W !,?4,"This routine will delete the ",ROLLRUNF," from the field.",!
  1.  ;
  1.  Q:$$YESDOIT("Are you certain you want to do this? ")="Q"
  1.  ;
  1.  Q:$$YESDOIT("Second Chance: Are you absolutely certain you want to do this? ")="Q"
  1.  ;
  1.  Q:$$YESDOIT("LAST CHANCE: Confirm you are certain you want to do this. ")="Q"
  1.  ;
  1.  S FDA(69.9,"1,",521)="@"
  1.  K ERRS
  1.  D FILE^DIE("K","FDA","ERRS")
  1.  ;
  1.  I $D(ERRS)>0 D  Q
  1.  . W !,?4,"Errors trying to clear the ROLLOVER RUNNING field.",!
  1.  . D ARRYDUMP("ERRS")
  1.  . D PRESSKEY^BLRGMENU(4)
  1.  ;
  1.  W !,?14,"Deleting"
  1.  F NUM=1:1:10 W "." H 1
  1.  W !,?14,"Done."
  1.  ;
  1.  W !!,?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field cleared."
  1.  ;
  1.  D PRESSKEY^BLRGMENU(14)
  1.  Q
  1.  ;
  1. YESDOIT(MESSAGE) ; EP - YES/NO Call
  1.  D ^XBFMK
  1.  S DIR(0)="YAO"
  1.  S DIR("A")=$J("",9)_MESSAGE
  1.  S DIR("B")="NO"
  1.  D ^DIR
  1.  ;
  1.  I +$G(Y)<1 D  Q "Q"
  1.  . W !!,?14,"NO/Null/Invalid Entry.  Routine ends."
  1.  . D PRESSKEY^BLRGMENU(19)
  1.  ;
  1.  W !
  1.  Q "OK"
  1.  ;
  1.  ; "Dump" the array -- written because SAC does not
  1.  ; allow use of Z routines.  ZW would have been better.
  1. ARRYDUMP(ARRY) ; EP
  1.   NEW STR1
  1.  ;
  1.  S STR1=$Q(@ARRY@(""))
  1.  W !,?9,ARRY,!
  1.  W ?14,STR1,"=",@STR1,!
  1.  F  S STR1=$Q(@STR1)  Q:STR1=""  D
  1.  . W ?14,STR1,"=",@STR1,!
  1.  Q
  1.  ;
  1. TESTIT ; EP - Test of routine
  1.  ; Force YES into the field
  1.  S $P(^LAB(69.9,1,"RO"),"^",2)=1
  1.  ;
  1.  D EP^BLRROLLD
  1.  Q