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