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

BLRADDCD.m

Go to the documentation of this file. 
  1. BLRADDCD ;IHS/MSC/MKK - Add Completed Date to all tests in an Accession ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
  1.  ;
  1.  ; This is a "quick and dirty" routine so as to help
  1.  ; sites with accessions that exist but do not have
  1.  ; any data in the Lab Data file. The only solution is
  1.  ; to put a COMPLETED DATE on ALL the tests in the Accession
  1.  ; and let ROLLOVER push them off the incomplete list.
  1.  ;
  1. EEP ; EP - Ersatz Entry Point
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  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.  D INITVARS
  1.  ;
  1.  F  Q:LRAS="Q"  D
  1.  . D HEADERDT^BLRGMENU
  1.  . Q:$$GETACCS(.LRAA,.LRAD,.LRAN,.LRAS)="Q"
  1.  . ;
  1.  . S COMPDATE=$$NOW^XLFDT
  1.  . ;
  1.  . S F60CNT=0,LRAT=.9999999
  1.  . F  S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT))  Q:LRAT<1  D
  1.  .. D WARMFZZY(LRAA,LRAD,LRAN,LRAT,.F60CNT,.F60IEN,.F60DESC)
  1.  .. ;
  1.  .. S IENS=LRAT_","_LRAN_","_LRAD_","_LRAA_","
  1.  .. ;
  1.  .. ; If already COMPLETED DATE, skip
  1.  .. I +$$GET1^DIQ(68.04,IENS,4,"I")  D DATEOKAY(F60IEN,F60DESC)  Q
  1.  .. ;
  1.  .. D ^XBFMK
  1.  .. K FDA,ERRS
  1.  .. S FDA(68.04,IENS,4)=COMPDATE
  1.  .. S FDA(68.04,IENS,5)="*Not Performed"
  1.  .. D FILE^DIE("KS","FDA","ERRS")
  1.  .. I $D(ERRS) D SHOWERRS("ACCESSION FILE",F60IEN,F60DESC)  Q
  1.  .. ;
  1.  .. ; Modify File 69
  1.  .. D ORDERMSG
  1.  .. ;
  1.  .. D SUCCESS(F60IEN,F60DESC)
  1.  . D:F60CNT<1 NOTESTS
  1.  . D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. INITVARS ; EP - Initialization of variables
  1.  S BLRVERN=$$TRIM^XLFSTR($P($T(+1),";"),"LR"," ")
  1.  ;
  1.  S HEADER(1)="Invalid Accession Fix"
  1.  S HEADER(2)="Add Completed Date to Tests"
  1.  ;
  1.  S LRAS="NOT YET"
  1.  S CDFIELDN=4             ; The Completed Date's field #
  1.  S DISPFLD=5              ; Disposition field
  1.  Q
  1.  ;
  1. GETACCS(LRAA,LRAD,LRAN,LRAS) ; EP - Get Accession Number
  1.  D ^LRWU4
  1.  I (LRAA<1)!(LRAD<1)!(LRAN<1) S LRAS="Q"  Q "Q"
  1.  ;
  1.  S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  I $G(LRAS)="" D BADENTRY  Q "Q"
  1.  ;
  1.  ; Skip if data exists in the Lab Data file for the Accession
  1.  NEW LRDFN,LRIDT,LRSS
  1.  S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=+$P($G(^(3)),"^",5)
  1.  S LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
  1.  ;
  1.  Q:$D(^LR(LRDFN,LRSS,LRIDT,0))<1 "OK"  ; No Data, okay to use
  1.  ;
  1.  W !!,?4,"Lab Data Exists for Accession ",LRAS,".",!!
  1.  W ?4,"Cannot Use that Accession.  Try Again."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  Q "Q"
  1.  ;
  1. GETCOMPD(COMPDATE) ; EP - Get Completed Date
  1.  W !!
  1.  D ^XBFMK
  1.  S DIR(0)="DAO"
  1.  S DIR("A")="Enter Completed Date:"
  1.  D ^DIR
  1.  I +$G(Y)<1 D BADENTRY  Q "Q"
  1.  ;
  1.  S COMPDATE=+$G(Y)
  1.  Q "OK"
  1.  ;
  1. BADENTRY ; EP - Invalid/No Data Entered.  Confirm quit
  1.  W !!
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("A")=$J("",4)_"Invalid/No Entry.  Try Again"
  1.  S DIR("B")="NO"
  1.  D ^DIR
  1.  I +$G(Y)<1 S LRAS="Q"
  1.  Q
  1.  ;
  1. NOTESTS ; EP - No Tests on the accesssion
  1.  W !!,?9,"No Tests on Accession."
  1.  Q
  1.  ;
  1. WARMFZZY(LRAA,LRAD,LRAN,LRAT,F60CNT,F60IEN,F60DESC) ; EP - "Warm Fuzzy" for user
  1.  S F60CNT=F60CNT+1
  1.  S F60IEN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT,0))
  1.  S F60DESC=$P($G(^LAB(60,F60IEN,0)),"^")
  1.  W:F60CNT=1 !!,?4,"For Accession ",LRAS,!
  1.  Q
  1.  ;
  1. DATEOKAY(F60IEN,F60DESC) ; EP
  1.  W ?9,"Completed Date already exists on test ",F60DESC," (#",F60IEN,").",!
  1.  Q
  1.  ;
  1. SUCCESS(F60IEN,F60DESC) ; EP
  1.  W ?9,"Completed Date added to test ",F60DESC," (#",F60IEN,").",!
  1.  Q
  1.  ;
  1. SHOWERRS(WOTFILE,F60IEN,F60DESC) ; EP - Show the details from the ERRORS Array
  1.  W ?9,"ERROR - Updating File ",WOTFILE,!
  1.  I $G(F60IEN)'="",$G(F60DESC)'="" W ?14,"Trying to Add Completed Date to test ",F60DESC," (#",F60IEN,").",!
  1.  D CHKERRS("FDA")
  1.  D CHKERRS("ERRS")
  1.  Q
  1.  ;
  1. CHKERRS(ARRY) ; EP - Errors Occurred.  Check them out.
  1.  NEW LEN,STR1,STR2,TAB
  1.  ;
  1.  ; The following code "dumps" the array.
  1.  S STR1=$Q(@ARRY@(""))
  1.  W ?14,STR1,"=",@STR1,!
  1.  F  S STR1=$Q(@STR1)  Q:STR1=""  D
  1.  . S STR2=@STR1
  1.  . W ?14,STR1,"="
  1.  . S TAB=$X
  1.  . S LEN=IOM-TAB                ; Max length before wrapping
  1.  . W $E(STR2,1,LEN-1),!
  1.  . W:$L(STR2)>(LEN-1) ?TAB,$E(STR2,LEN,9999),!
  1.  W !
  1.  Q
  1.  ;
  1.  ; Setup Order file with "Cancelled" message, if it doesn't exist already
  1. ORDERMSG ; EP
  1.  NEW DONE,LRORD,LRORN,LRORT,NOWDT,NOWDTT,ORDERN,STR
  1.  NEW ERRS,FDA,FDAIENS
  1.  ;
  1.  S ORDERN=+$G(^LRO(68,LRAA,1,LRAN,1,LRAN,.1))
  1.  ;
  1.  S (DONE,LRORD,LRORN,LRORT)=0
  1.  F  S LRORD=$O(^LRO(69,"C",ORDERN,LRORD))  Q:LRORD<1!(DONE)  D
  1.  . F  S LRORN=$O(^LRO(69,"C",ORDERN,LRORD,LRORN))  Q:LRORN<1!(DONE)  D
  1.  .. F  S LRORT=$O(^LRO(69,LRORD,1,LRORN,2,LRORT))  Q:LRORT<1!(DONE)  D
  1.  ... S STR=$G(^LRO(69,LRORD,1,LRORN,2,LRORT,0))
  1.  ... Q:+STR'=LRAT
  1.  ... ;
  1.  ... ; Skip if already cancelled
  1.  ... Q:$L($P(^LRO(69,LRORD,1,LRORN,2,LRORT,0),"^",11))
  1.  ... ;
  1.  ... S FDAIENS=LRORT_","_LRORN_","_LRORD_","
  1.  ... K FDA
  1.  ... S FDA(69.03,FDAIENS,8)="CA"
  1.  ... S FDA(69.03,FDAIENS,11)=$G(DUZ)
  1.  ... D FILE^DIE("KS","FDA","ERRS")
  1.  ... I $D(ERRS) D SHOWERRS("Order File")  Q
  1.  ... D MAKEMESG(LRORD,LRORN,LRORT)
  1.  ... S DONE=1
  1.  Q
  1.  ;
  1.  ; S LRODT=LRORD,LRSN=LRORN,LRI=LRORT
  1. MAKEMESG(LRODT,LRSN,LRI) ; EP - Create the cancel reason in 69 - some code cloned from LRHYDEL routine.
  1.  NEW ORIFN,LRODT,LRSN,LRI,II
  1.  ;
  1.  S (LRSTATUS,II(LRAT))=""
  1.  ;
  1.  S ORIFN=$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,7)
  1.  S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="OTHER CANCEL REASON: *NP Reason:Malformed Accession"
  1.  S X=X+1,X(1)=X(1)+1
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*NP Action:"_$$HTE^XLFDT($H,"5MZ")
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
  1.  I $G(ORIFN),$D(II) D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.II,LRSTATUS)
  1.  I ORIFN,$$VER^LR7OU1<3 D DC^LRCENDE1
  1.  S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
  1.  S:$D(^LRO(69,LRODT,1,LRSN,"PCE")) ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""
  1.  Q