BLRPURGU ; IHS/MSC/MKK - Purge Old Orders & Accessions Utilities ; 13-Oct-2017 14:04 ; MKK
;;5.2;LAB SERVICE;**1041**;NOV 1, 1997;Build 23
;
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 SETBLRVS
;
D ADDTMENU^BLRGMENU("REPORT^BLRPURGU","Report by Date")
D ADDTMENU^BLRGMENU("DUZRPT^BLRPURGU","Report by User")
;
S BLRIEN=$$FIND1^DIC(9.4,,"M","BLR")
S PKGNAME=$S(BLRIEN:$$GET1^DIQ(9.4,BLRIEN,.01),1:"RPMS Laboratory")
;
D MENUDRVR^BLRGMENU(PKGNAME,"Purge old orders & accessions Reports")
Q
;
REPORT ; EP - Main Report
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$$REPORTI()="Q"
;
F S DEEZ=$O(^BLRPURGU(DEEZ),-1) Q:DEEZ<1!(QFLG="Q") D
. S PURGDTT=$$GET1^DIQ(90475.8,DEEZ,.01,"I")
. S USER=$$GET1^DIQ(90475.8,DEEZ,1,"I")
. S USERDIV=$$GET1^DIQ(90475.8,DEEZ,2,"I")
. ;
. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE) Q:QFLG="Q"
. ;
. W $$FMTE^XLFDT(PURGDTT,"5MZ")
. W ?19,USER
. W ?29,$$GET1^DIQ(200,USER,.01)
. W ?49,USERDIV
. D LINEWRAP^BLRGMENU(59,$$GET1^DIQ(4,USERDIV,.01),21)
. W !
. S CNT=CNT+1
;
W !!,?4,CNT," 'Purge Old Orders & Accessions' entr",$$PLURALI(CNT),"."
D PRESSKEY^BLRGMENU(9)
Q
;
REPORTI() ; EP - Initialization
D SETBLRVS
;
S HEADER(1)="Purge Old Orders & Accessions"
S GRACEPO=$$GET1^DIQ(69.9,1,15)
S HEADER(2)="File 69.9 Grace Period For Orders: "_$S(GRACEPO:GRACEPO_" Days",1:"Not Set")
S HEADER(3)=$$CJ^XLFSTR("Reverse Date Listing",IOM)
;
D HEADERDT^BLRGMENU
D HEADONE^BLRGMENU(.HDRONE)
D HEADERDT^BLRGMENU
D ^%ZIS
I POP Q $$BADSTUFQ("^%ZIS Problem.")
;
D HEADERDT^BLRGMENU
S HEADER(4)=" "
S HEADER(5)="Purge Date/Time"
S $E(HEADER(5),20)="DUZ"
S $E(HEADER(5),30)="Name"
S $E(HEADER(5),50)="Division"
S $E(HEADER(5),60)="Division Description"
;
S MAXLINES=IOSL-4,LINES=MAXLINES+10
S (CNT,PG)=0,QFLG="NO",DEEZ="A"
Q "OK"
;
;
DUZRPT ; EP - Report by User
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$$DUZRPTI()="Q"
;
F S USER=$O(^BLRPURGU("C",USER)) Q:USER<1!(QFLG="Q") D
. S DEEZ="A"
. F S DEEZ=$O(^BLRPURGU("C",USER,DEEZ),-1) Q:DEEZ<1 D
.. S PURGDTT=$$GET1^DIQ(90475.8,DEEZ,.01,"I")
.. S USERDIV=$$GET1^DIQ(90475.8,DEEZ,2,"I")
.. ;
.. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE) Q:QFLG="Q"
.. ;
.. W $$FMTE^XLFDT(PURGDTT,"5MZ")
.. W ?19,USER
.. W ?29,$$GET1^DIQ(200,USER,.01)
.. W ?49,USERDIV
.. D LINEWRAP^BLRGMENU(59,$$GET1^DIQ(4,USERDIV,.01),21)
.. W !
.. S CNT=CNT+1
;
W !!,?4,CNT," 'Purge Old Orders & Accessions' entr",$$PLURALI(CNT),"."
D PRESSKEY^BLRGMENU(9)
Q
;
DUZRPTI() ; EP - Initialization
D SETBLRVS
;
S HEADER(1)="Purge Old Orders & Accessions"
S GRACEPO=$$GET1^DIQ(69.9,1,15)
S HEADER(2)="File 69.9 Grace Period For Orders: "_$S(GRACEPO:GRACEPO_" Days",1:"Not Set")
S HEADER(3)=$$CJ^XLFSTR("User Sorted Listing",IOM)
;
D HEADERDT^BLRGMENU
D HEADONE^BLRGMENU(.HDRONE)
D HEADERDT^BLRGMENU
D ^%ZIS
I POP Q $$BADSTUFQ("^%ZIS Problem.")
;
D HEADERDT^BLRGMENU
S HEADER(4)=" "
S HEADER(5)="Purge Date/Time"
S $E(HEADER(5),20)="DUZ"
S $E(HEADER(5),30)="Name"
S $E(HEADER(5),50)="Division"
S $E(HEADER(5),60)="Division Description"
;
S MAXLINES=IOSL-4,LINES=MAXLINES+10
S (CNT,PG,USER)=0,QFLG="NO"
Q "OK"
;
;
STORPURG ; EP - Store Purging Data - Called from LROC
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S NOW=$$NOW^XLFDT
S FDA(90475.8,"?+1,",.01)=NOW
S FDA(90475.8,"?+1,",1)=DUZ
S FDA(90475.8,"?+1,",2)=DUZ(2)
D UPDATE^DIE("S","FDA",,"ERRS")
Q:$D(ERRS)<1
;
S STR(1)="Purge Old Orders & Accessions UPDATE^DIE call failed."
S STR(2)=" "
S STR(3)=$TR($$CJ^XLFSTR("@FDA@",50)," @","= ")
S $E(STR(4),10)="FDA(90475.8,""?+1,"",.01)="_NOW
S $E(STR(5),10)="FDA(90475.8,""?+1,"",.1)="_DUZ
;
D MAILALMI^BLRUTIL3("Purge Old Orders & Accessions UPDATE-DIE call failed",.STR,"STORPURG-BLRPURGU")
Q
;
;
; ============================= UTILITIES =============================
;
JUSTNEW ; EP - Generic RPMS EXCLUSIVE NEW
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q
;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
K BLRVERN,BLRVERN2
;
S BLRVERN=$P($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=$G(TWO)
Q
;
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
;
BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message. Ends with Q "Q"uit
D BADSTUFF(STR,$G(TAB))
Q "Q"
;
PLURALI(CNT) ; EP - If CNT'=1, return IES else return Y
Q $S(CNT=1:"y",1:"ies")
BLRPURGU ; IHS/MSC/MKK - Purge Old Orders & Accessions Utilities ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;LAB SERVICE;**1041**;NOV 1, 1997;Build 23
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ;
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 SETBLRVS
+4 ;
+5 DO ADDTMENU^BLRGMENU("REPORT^BLRPURGU","Report by Date")
+6 DO ADDTMENU^BLRGMENU("DUZRPT^BLRPURGU","Report by User")
+7 ;
+8 SET BLRIEN=$$FIND1^DIC(9.4,,"M","BLR")
+9 SET PKGNAME=$SELECT(BLRIEN:$$GET1^DIQ(9.4,BLRIEN,.01),1:"RPMS Laboratory")
+10 ;
+11 DO MENUDRVR^BLRGMENU(PKGNAME,"Purge old orders & accessions Reports")
+12 QUIT
+13 ;
REPORT ; EP - Main Report
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$REPORTI()="Q"
QUIT
+4 ;
+5 FOR
SET DEEZ=$ORDER(^BLRPURGU(DEEZ),-1)
IF DEEZ<1!(QFLG="Q")
QUIT
Begin DoDot:1
+6 SET PURGDTT=$$GET1^DIQ(90475.8,DEEZ,.01,"I")
+7 SET USER=$$GET1^DIQ(90475.8,DEEZ,1,"I")
+8 SET USERDIV=$$GET1^DIQ(90475.8,DEEZ,2,"I")
+9 ;
+10 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
IF QFLG="Q"
QUIT
+11 ;
+12 WRITE $$FMTE^XLFDT(PURGDTT,"5MZ")
+13 WRITE ?19,USER
+14 WRITE ?29,$$GET1^DIQ(200,USER,.01)
+15 WRITE ?49,USERDIV
+16 DO LINEWRAP^BLRGMENU(59,$$GET1^DIQ(4,USERDIV,.01),21)
+17 WRITE !
+18 SET CNT=CNT+1
End DoDot:1
+19 ;
+20 WRITE !!,?4,CNT," 'Purge Old Orders & Accessions' entr",$$PLURALI(CNT),"."
+21 DO PRESSKEY^BLRGMENU(9)
+22 QUIT
+23 ;
REPORTI() ; EP - Initialization
+1 DO SETBLRVS
+2 ;
+3 SET HEADER(1)="Purge Old Orders & Accessions"
+4 SET GRACEPO=$$GET1^DIQ(69.9,1,15)
+5 SET HEADER(2)="File 69.9 Grace Period For Orders: "_$SELECT(GRACEPO:GRACEPO_" Days",1:"Not Set")
+6 SET HEADER(3)=$$CJ^XLFSTR("Reverse Date Listing",IOM)
+7 ;
+8 DO HEADERDT^BLRGMENU
+9 DO HEADONE^BLRGMENU(.HDRONE)
+10 DO HEADERDT^BLRGMENU
+11 DO ^%ZIS
+12 IF POP
QUIT $$BADSTUFQ("^%ZIS Problem.")
+13 ;
+14 DO HEADERDT^BLRGMENU
+15 SET HEADER(4)=" "
+16 SET HEADER(5)="Purge Date/Time"
+17 SET $EXTRACT(HEADER(5),20)="DUZ"
+18 SET $EXTRACT(HEADER(5),30)="Name"
+19 SET $EXTRACT(HEADER(5),50)="Division"
+20 SET $EXTRACT(HEADER(5),60)="Division Description"
+21 ;
+22 SET MAXLINES=IOSL-4
SET LINES=MAXLINES+10
+23 SET (CNT,PG)=0
SET QFLG="NO"
SET DEEZ="A"
+24 QUIT "OK"
+25 ;
+26 ;
DUZRPT ; EP - Report by User
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$DUZRPTI()="Q"
QUIT
+4 ;
+5 FOR
SET USER=$ORDER(^BLRPURGU("C",USER))
IF USER<1!(QFLG="Q")
QUIT
Begin DoDot:1
+6 SET DEEZ="A"
+7 FOR
SET DEEZ=$ORDER(^BLRPURGU("C",USER,DEEZ),-1)
IF DEEZ<1
QUIT
Begin DoDot:2
+8 SET PURGDTT=$$GET1^DIQ(90475.8,DEEZ,.01,"I")
+9 SET USERDIV=$$GET1^DIQ(90475.8,DEEZ,2,"I")
+10 ;
+11 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
IF QFLG="Q"
QUIT
+12 ;
+13 WRITE $$FMTE^XLFDT(PURGDTT,"5MZ")
+14 WRITE ?19,USER
+15 WRITE ?29,$$GET1^DIQ(200,USER,.01)
+16 WRITE ?49,USERDIV
+17 DO LINEWRAP^BLRGMENU(59,$$GET1^DIQ(4,USERDIV,.01),21)
+18 WRITE !
+19 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+20 ;
+21 WRITE !!,?4,CNT," 'Purge Old Orders & Accessions' entr",$$PLURALI(CNT),"."
+22 DO PRESSKEY^BLRGMENU(9)
+23 QUIT
+24 ;
DUZRPTI() ; EP - Initialization
+1 DO SETBLRVS
+2 ;
+3 SET HEADER(1)="Purge Old Orders & Accessions"
+4 SET GRACEPO=$$GET1^DIQ(69.9,1,15)
+5 SET HEADER(2)="File 69.9 Grace Period For Orders: "_$SELECT(GRACEPO:GRACEPO_" Days",1:"Not Set")
+6 SET HEADER(3)=$$CJ^XLFSTR("User Sorted Listing",IOM)
+7 ;
+8 DO HEADERDT^BLRGMENU
+9 DO HEADONE^BLRGMENU(.HDRONE)
+10 DO HEADERDT^BLRGMENU
+11 DO ^%ZIS
+12 IF POP
QUIT $$BADSTUFQ("^%ZIS Problem.")
+13 ;
+14 DO HEADERDT^BLRGMENU
+15 SET HEADER(4)=" "
+16 SET HEADER(5)="Purge Date/Time"
+17 SET $EXTRACT(HEADER(5),20)="DUZ"
+18 SET $EXTRACT(HEADER(5),30)="Name"
+19 SET $EXTRACT(HEADER(5),50)="Division"
+20 SET $EXTRACT(HEADER(5),60)="Division Description"
+21 ;
+22 SET MAXLINES=IOSL-4
SET LINES=MAXLINES+10
+23 SET (CNT,PG,USER)=0
SET QFLG="NO"
+24 QUIT "OK"
+25 ;
+26 ;
STORPURG ; EP - Store Purging Data - Called from LROC
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET NOW=$$NOW^XLFDT
+4 SET FDA(90475.8,"?+1,",.01)=NOW
+5 SET FDA(90475.8,"?+1,",1)=DUZ
+6 SET FDA(90475.8,"?+1,",2)=DUZ(2)
+7 DO UPDATE^DIE("S","FDA",,"ERRS")
+8 IF $DATA(ERRS)<1
QUIT
+9 ;
+10 SET STR(1)="Purge Old Orders & Accessions UPDATE^DIE call failed."
+11 SET STR(2)=" "
+12 SET STR(3)=$TRANSLATE($$CJ^XLFSTR("@FDA@",50)," @","= ")
+13 SET $EXTRACT(STR(4),10)="FDA(90475.8,""?+1,"",.01)="_NOW
+14 SET $EXTRACT(STR(5),10)="FDA(90475.8,""?+1,"",.1)="_DUZ
+15 ;
+16 DO MAILALMI^BLRUTIL3("Purge Old Orders & Accessions UPDATE-DIE call failed",.STR,"STORPURG-BLRPURGU")
+17 QUIT
+18 ;
+19 ;
+20 ; ============================= UTILITIES =============================
+21 ;
JUSTNEW ; EP - Generic RPMS EXCLUSIVE NEW
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 QUIT
+4 ;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
+1 KILL BLRVERN,BLRVERN2
+2 ;
+3 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+4 IF $LENGTH($GET(TWO))
SET BLRVERN2=$GET(TWO)
+5 QUIT
+6 ;
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 ;
BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message. Ends with Q "Q"uit
+1 DO BADSTUFF(STR,$GET(TAB))
+2 QUIT "Q"
+3 ;
PLURALI(CNT) ; EP - If CNT'=1, return IES else return Y
+1 QUIT $SELECT(CNT=1:"y",1:"ies")
