BLRROLLD ; IHS/OIT/MKK - Delete anything in ROLLOVER RUNNING field in File 69.9 ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS Laboratory;**1033**;NOV 01, 1997
;
; This routine was created to allow Laboratory personnel who do not have FileMan
; access the ability to clear the ROLLOVER RUNNING (#521) field in the
; LABORATORY SITE (#69.9) file.
;
EEP ; EP - Ersatz Entry
D EEP^BLRGMENU
Q
;
; Delete anything in Field 521 (ROLLOVER RUNNING) field in 69.9
PEP ; EP
EP ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S BLRVERN=$P($P($T(+1),";")," ")
S HEADER(1)="IHS RPMS Laboratory Module"
S HEADER(2)="LABORATORY SITE (#69.9) File"
S HEADER(3)=$$CJ^XLFSTR("ROLLOVER RUNNING (#521) field",IOM)
D HEADERDT^BLRGMENU
;
I $D(^XUSEC("LRSUPER",DUZ))<1 D Q
. S LINE1="*** User "_$P($G(^VA(200,DUZ,0)),"^")_" [DUZ:"_DUZ_"] ***"
. S LINE2="*** does NOT have the LRSUPER Security Key. ***"
. ;
. S MAXLINE=$L(LINE1)
. I $L(LINE2)>MAXLINE D
.. S MAXLINE=$L(LINE2)
.. S LINE1=$$LJ^XLFSTR("*** User "_$P($G(^VA(200,DUZ,0)),"^")_" [DUZ:"_DUZ_"]",MAXLINE-4)_" ***"
. ;
. W !,?14,$TR($J("",MAXLINE)," ","*"),!
. W ?14,LINE1,!
. W ?14,LINE2,!
. W ?14,$$LJ^XLFSTR("*** ",MAXLINE-4)," ***",!
. W ?14,$$LJ^XLFSTR("*** Routine Ends.",MAXLINE-4)," ***",!
. W ?14,$TR($J("",MAXLINE)," ","*"),!
. D PRESSKEY^BLRGMENU(9)
;
S ROLLRUNF=$$GET1^DIQ(69.9,"1,",521)
I ROLLRUNF="" D Q
. W ?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field is Null.",!!
. W ?4,"No need to delete anything. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
W ?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field = ",ROLLRUNF,!
;
W !,?4,"This routine will delete the ",ROLLRUNF," from the field.",!
;
Q:$$YESDOIT("Are you certain you want to do this? ")="Q"
;
Q:$$YESDOIT("Second Chance: Are you absolutely certain you want to do this? ")="Q"
;
Q:$$YESDOIT("LAST CHANCE: Confirm you are certain you want to do this. ")="Q"
;
S FDA(69.9,"1,",521)="@"
K ERRS
D FILE^DIE("K","FDA","ERRS")
;
I $D(ERRS)>0 D Q
. W !,?4,"Errors trying to clear the ROLLOVER RUNNING field.",!
. D ARRYDUMP("ERRS")
. D PRESSKEY^BLRGMENU(4)
;
W !,?14,"Deleting"
F NUM=1:1:10 W "." H 1
W !,?14,"Done."
;
W !!,?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field cleared."
;
D PRESSKEY^BLRGMENU(14)
Q
;
YESDOIT(MESSAGE) ; EP - YES/NO Call
D ^XBFMK
S DIR(0)="YAO"
S DIR("A")=$J("",9)_MESSAGE
S DIR("B")="NO"
D ^DIR
;
I +$G(Y)<1 D Q "Q"
. W !!,?14,"NO/Null/Invalid Entry. Routine ends."
. D PRESSKEY^BLRGMENU(19)
;
W !
Q "OK"
;
; "Dump" the array -- written because SAC does not
; allow use of Z routines. ZW would have been better.
ARRYDUMP(ARRY) ; EP
NEW STR1
;
S STR1=$Q(@ARRY@(""))
W !,?9,ARRY,!
W ?14,STR1,"=",@STR1,!
F S STR1=$Q(@STR1) Q:STR1="" D
. W ?14,STR1,"=",@STR1,!
Q
;
TESTIT ; EP - Test of routine
; Force YES into the field
S $P(^LAB(69.9,1,"RO"),"^",2)=1
;
D EP^BLRROLLD
Q
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
+2 ;
+3 ; This routine was created to allow Laboratory personnel who do not have FileMan
+4 ; access the ability to clear the ROLLOVER RUNNING (#521) field in the
+5 ; LABORATORY SITE (#69.9) file.
+6 ;
EEP ; EP - Ersatz Entry
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ; Delete anything in Field 521 (ROLLOVER RUNNING) field in 69.9
PEP ; EP
EP ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+4 SET HEADER(1)="IHS RPMS Laboratory Module"
+5 SET HEADER(2)="LABORATORY SITE (#69.9) File"
+6 SET HEADER(3)=$$CJ^XLFSTR("ROLLOVER RUNNING (#521) field",IOM)
+7 DO HEADERDT^BLRGMENU
+8 ;
+9 IF $DATA(^XUSEC("LRSUPER",DUZ))<1
Begin DoDot:1
+10 SET LINE1="*** User "_$PIECE($GET(^VA(200,DUZ,0)),"^")_" [DUZ:"_DUZ_"] ***"
+11 SET LINE2="*** does NOT have the LRSUPER Security Key. ***"
+12 ;
+13 SET MAXLINE=$LENGTH(LINE1)
+14 IF $LENGTH(LINE2)>MAXLINE
Begin DoDot:2
+15 SET MAXLINE=$LENGTH(LINE2)
+16 SET LINE1=$$LJ^XLFSTR("*** User "_$PIECE($GET(^VA(200,DUZ,0)),"^")_" [DUZ:"_DUZ_"]",MAXLINE-4)_" ***"
End DoDot:2
+17 ;
+18 WRITE !,?14,$TRANSLATE($JUSTIFY("",MAXLINE)," ","*"),!
+19 WRITE ?14,LINE1,!
+20 WRITE ?14,LINE2,!
+21 WRITE ?14,$$LJ^XLFSTR("*** ",MAXLINE-4)," ***",!
+22 WRITE ?14,$$LJ^XLFSTR("*** Routine Ends.",MAXLINE-4)," ***",!
+23 WRITE ?14,$TRANSLATE($JUSTIFY("",MAXLINE)," ","*"),!
+24 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+25 ;
+26 SET ROLLRUNF=$$GET1^DIQ(69.9,"1,",521)
+27 IF ROLLRUNF=""
Begin DoDot:1
+28 WRITE ?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field is Null.",!!
+29 WRITE ?4,"No need to delete anything. Routine Ends."
+30 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+31 ;
+32 WRITE ?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field = ",ROLLRUNF,!
+33 ;
+34 WRITE !,?4,"This routine will delete the ",ROLLRUNF," from the field.",!
+35 ;
+36 IF $$YESDOIT("Are you certain you want to do this? ")="Q"
QUIT
+37 ;
+38 IF $$YESDOIT("Second Chance
QUIT
+39 ;
+40 IF $$YESDOIT("LAST CHANCE
QUIT
+41 ;
+42 SET FDA(69.9,"1,",521)="@"
+43 KILL ERRS
+44 DO FILE^DIE("K","FDA","ERRS")
+45 ;
+46 IF $DATA(ERRS)>0
Begin DoDot:1
+47 WRITE !,?4,"Errors trying to clear the ROLLOVER RUNNING field.",!
+48 DO ARRYDUMP("ERRS")
+49 DO PRESSKEY^BLRGMENU(4)
End DoDot:1
QUIT
+50 ;
+51 WRITE !,?14,"Deleting"
+52 FOR NUM=1:1:10
WRITE "."
HANG 1
+53 WRITE !,?14,"Done."
+54 ;
+55 WRITE !!,?4,"LABORATORY SITE (#69.9) file's ROLLOVER RUNNING (#521) field cleared."
+56 ;
+57 DO PRESSKEY^BLRGMENU(14)
+58 QUIT
+59 ;
YESDOIT(MESSAGE) ; EP - YES/NO Call
+1 DO ^XBFMK
+2 SET DIR(0)="YAO"
+3 SET DIR("A")=$JUSTIFY("",9)_MESSAGE
+4 SET DIR("B")="NO"
+5 DO ^DIR
+6 ;
+7 IF +$GET(Y)<1
Begin DoDot:1
+8 WRITE !!,?14,"NO/Null/Invalid Entry. Routine ends."
+9 DO PRESSKEY^BLRGMENU(19)
End DoDot:1
QUIT "Q"
+10 ;
+11 WRITE !
+12 QUIT "OK"
+13 ;
+14 ; "Dump" the array -- written because SAC does not
+15 ; allow use of Z routines. ZW would have been better.
ARRYDUMP(ARRY) ; EP
+1 NEW STR1
+2 ;
+3 SET STR1=$QUERY(@ARRY@(""))
+4 WRITE !,?9,ARRY,!
+5 WRITE ?14,STR1,"=",@STR1,!
+6 FOR
SET STR1=$QUERY(@STR1)
IF STR1=""
QUIT
Begin DoDot:1
+7 WRITE ?14,STR1,"=",@STR1,!
End DoDot:1
+8 QUIT
+9 ;
TESTIT ; EP - Test of routine
+1 ; Force YES into the field
+2 SET $PIECE(^LAB(69.9,1,"RO"),"^",2)=1
+3 ;
+4 DO EP^BLRROLLD
+5 QUIT
