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

BLRPURGU.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  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 SETBLRVS
  1.  ;
  1.  D ADDTMENU^BLRGMENU("REPORT^BLRPURGU","Report by Date")
  1.  D ADDTMENU^BLRGMENU("DUZRPT^BLRPURGU","Report by User")
  1.  ;
  1.  S BLRIEN=$$FIND1^DIC(9.4,,"M","BLR")
  1.  S PKGNAME=$S(BLRIEN:$$GET1^DIQ(9.4,BLRIEN,.01),1:"RPMS Laboratory")
  1.  ;
  1.  D MENUDRVR^BLRGMENU(PKGNAME,"Purge old orders & accessions Reports")
  1.  Q
  1.  ;
  1. REPORT ; EP - Main Report
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$REPORTI()="Q"
  1.  ;
  1.  F  S DEEZ=$O(^BLRPURGU(DEEZ),-1)  Q:DEEZ<1!(QFLG="Q")  D
  1.  . S PURGDTT=$$GET1^DIQ(90475.8,DEEZ,.01,"I")
  1.  . S USER=$$GET1^DIQ(90475.8,DEEZ,1,"I")
  1.  . S USERDIV=$$GET1^DIQ(90475.8,DEEZ,2,"I")
  1.  . ;
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  . ;
  1.  . W $$FMTE^XLFDT(PURGDTT,"5MZ")
  1.  . W ?19,USER
  1.  . W ?29,$$GET1^DIQ(200,USER,.01)
  1.  . W ?49,USERDIV
  1.  . D LINEWRAP^BLRGMENU(59,$$GET1^DIQ(4,USERDIV,.01),21)
  1.  . W !
  1.  . S CNT=CNT+1
  1.  ;
  1.  W !!,?4,CNT," 'Purge Old Orders & Accessions' entr",$$PLURALI(CNT),"."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. REPORTI() ; EP - Initialization
  1.  D SETBLRVS
  1.  ;
  1.  S HEADER(1)="Purge Old Orders & Accessions"
  1.  S GRACEPO=$$GET1^DIQ(69.9,1,15)
  1.  S HEADER(2)="File 69.9 Grace Period For Orders: "_$S(GRACEPO:GRACEPO_" Days",1:"Not Set")
  1.  S HEADER(3)=$$CJ^XLFSTR("Reverse Date Listing",IOM)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  D HEADERDT^BLRGMENU
  1.  D ^%ZIS
  1.  I POP Q $$BADSTUFQ("^%ZIS Problem.")
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  S HEADER(4)=" "
  1.  S HEADER(5)="Purge Date/Time"
  1.  S $E(HEADER(5),20)="DUZ"
  1.  S $E(HEADER(5),30)="Name"
  1.  S $E(HEADER(5),50)="Division"
  1.  S $E(HEADER(5),60)="Division Description"
  1.  ;
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  S (CNT,PG)=0,QFLG="NO",DEEZ="A"
  1.  Q "OK"
  1.  ;
  1.  ;
  1. 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)
  1.  ;
  1.  Q:$$DUZRPTI()="Q"
  1.  ;
  1.  F  S USER=$O(^BLRPURGU("C",USER))  Q:USER<1!(QFLG="Q")  D
  1.  . S DEEZ="A"
  1.  . F  S DEEZ=$O(^BLRPURGU("C",USER,DEEZ),-1)  Q:DEEZ<1  D
  1.  .. S PURGDTT=$$GET1^DIQ(90475.8,DEEZ,.01,"I")
  1.  .. S USERDIV=$$GET1^DIQ(90475.8,DEEZ,2,"I")
  1.  .. ;
  1.  .. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  .. ;
  1.  .. W $$FMTE^XLFDT(PURGDTT,"5MZ")
  1.  .. W ?19,USER
  1.  .. W ?29,$$GET1^DIQ(200,USER,.01)
  1.  .. W ?49,USERDIV
  1.  .. D LINEWRAP^BLRGMENU(59,$$GET1^DIQ(4,USERDIV,.01),21)
  1.  .. W !
  1.  .. S CNT=CNT+1
  1.  ;
  1.  W !!,?4,CNT," 'Purge Old Orders & Accessions' entr",$$PLURALI(CNT),"."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. DUZRPTI() ; EP - Initialization
  1.  D SETBLRVS
  1.  ;
  1.  S HEADER(1)="Purge Old Orders & Accessions"
  1.  S GRACEPO=$$GET1^DIQ(69.9,1,15)
  1.  S HEADER(2)="File 69.9 Grace Period For Orders: "_$S(GRACEPO:GRACEPO_" Days",1:"Not Set")
  1.  S HEADER(3)=$$CJ^XLFSTR("User Sorted Listing",IOM)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  D HEADERDT^BLRGMENU
  1.  D ^%ZIS
  1.  I POP Q $$BADSTUFQ("^%ZIS Problem.")
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  S HEADER(4)=" "
  1.  S HEADER(5)="Purge Date/Time"
  1.  S $E(HEADER(5),20)="DUZ"
  1.  S $E(HEADER(5),30)="Name"
  1.  S $E(HEADER(5),50)="Division"
  1.  S $E(HEADER(5),60)="Division Description"
  1.  ;
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  S (CNT,PG,USER)=0,QFLG="NO"
  1.  Q "OK"
  1.  ;
  1.  ;
  1. 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)
  1.  ;
  1.  S NOW=$$NOW^XLFDT
  1.  S FDA(90475.8,"?+1,",.01)=NOW
  1.  S FDA(90475.8,"?+1,",1)=DUZ
  1.  S FDA(90475.8,"?+1,",2)=DUZ(2)
  1.  D UPDATE^DIE("S","FDA",,"ERRS")
  1.  Q:$D(ERRS)<1
  1.  ;
  1.  S STR(1)="Purge Old Orders & Accessions UPDATE^DIE call failed."
  1.  S STR(2)=" "
  1.  S STR(3)=$TR($$CJ^XLFSTR("@FDA@",50)," @","= ")
  1.  S $E(STR(4),10)="FDA(90475.8,""?+1,"",.01)="_NOW
  1.  S $E(STR(5),10)="FDA(90475.8,""?+1,"",.1)="_DUZ
  1.  ;
  1.  D MAILALMI^BLRUTIL3("Purge Old Orders & Accessions UPDATE-DIE call failed",.STR,"STORPURG-BLRPURGU")
  1.  Q
  1.  ;
  1.  ;
  1.  ; ============================= UTILITIES =============================
  1.  ;
  1. 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)
  1.  ;
  1.  Q
  1.  ;
  1. SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
  1.  K BLRVERN,BLRVERN2
  1.  ;
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  S:$L($G(TWO)) BLRVERN2=$G(TWO)
  1.  Q
  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. BADSTUFQ(STR,TAB) ; EP - BADSTUFF error message.  Ends with Q "Q"uit
  1.  D BADSTUFF(STR,$G(TAB))
  1.  Q "Q"
  1.  ;
  1. PLURALI(CNT) ; EP - If CNT'=1, return IES else return Y
  1.  Q $S(CNT=1:"y",1:"ies")