BLRAGUT1 ; IHS/MSC/SAT - Fix for Downed PCC Linker (Utilities) ; [ 07/16/2012 4:00 PM ]
;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
;
;
SETUP() ;
S NOTSENT=0
S AUTOLOAD=0
S YEARAGO=$$FMADD^XLFDT($$NOW^XLFDT(),-365)
Q $$SETVARS()
;
SETVARS() ; EP - Set the necessary variables for BLREVTQ to work
S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)) ; Get Accession
I $L(LRAS)<1 Q $$WHYNOT("<NULL>","Accession string does not exist")
;
I +$O(^BLRTXLOG("D",LRAS,0)) Q $$WHYNOT(LRAS,"Accession already in ^BLRTXLOG")
;
S LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
I LRSS'="CH"&(LRSS'="MI") Q $$WHYNOT(LRAS,"Accession not 'CH' nor 'MI' Subscript")
;
S ORIGACCD=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3) ; Original Accession Date
I ORIGACCD<YEARAGO Q $$WHYNOT(LRAS,"Original Accession Date More than a Year Ago")
;
S ORDNUM=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
I ORDNUM<1 Q $$WHYNOT(LRAS,"Order Number does not exist")
;
S:+$G(LRODT)<1 LRODT=+$O(^LRO(69,"C",ORDNUM,0))
I LRODT<1 Q $$WHYNOT(LRAS,"Order Number "_ORDNUM_"'s Order Date does not exist for "_LRAD_" Accession Date")
;
S:+$G(LRSN)<1 LRSN=+$O(^LRO(69,"C",ORDNUM,LRODT,0))
I LRSN<1 Q $$WHYNOT(LRAS,"Order Date's LRSN:"_LRSN_" does not exist")
;
;S DTTRAVIL=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",4) ; Date/Time Results Available
;I +DTTRAVIL<1 Q $$WHYNOT(LRAS,"No 'Results Available' Date")
;
S LRCDT=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) ; Collection Date/Time
;
I $$PCCVFILE(LRAA,LRAS,LRCDT,LRSS,.PCCVISIT) Q $$WHYNOT(LRAS,"PCC Visit "_PCCVISIT_" Matched "_$P(LRCDT,".")_" Collection Date.")
S (D0,DA,LRIDT)=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5) ; Inverse Date
;
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
S DFN=+$P($G(^LR(LRDFN,0)),"^",3)
I DFN<1 Q $$WHYNOT(LRAS,"LRDFN "_LRDFN_" has no DFN.")
;
D DFN^LRDAGE(DFN,2,LRCDT)
S (BID,HRCN,PID)=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),"^",2)
S PNM=$P($G(^DPT(DFN,0)),"^"),STR=$RE($P($G(^(0)),"^",9))
S SSN=$RE($E(STR,7,9))_"-"_$RE($E(STR,5,6))_"-"_$RE($E(STR,1,4))
;
S BLRCMF="M",BLRDH=+$H,BLRLOG=1,BLRPCC=1
;S BLROPT="BYPASS" ; Set to BYPASS because its already resulted
;S BLRPHASE="R" ; Set phase to RESULTing
S BLRQSITE=DUZ(2),BLRQUIET=1,BLRSTOP=0
S (BLRIDS,LRACC)=LRAS
;
S STR=$$FMTE^XLFDT(LRCDT,"2M")
S LRDAT=$P(STR,"/",1,2)_" "_$TR($P(STR,"@",2),":")_"d"
;
S (LRACD,LRAOD)=LRAD
S LRDT0=$$HTE^XLFDT($H,"2D")
S LRLABKY="1^1^1^1"
S LRLOCKER="^LR("_LRDFN_","_$C(34)_LRSS_$C(34)_","_LRIDT_")"
S LROUTINE=9,LRPANEL=0,LRPCEVSO=1
;
S PTR=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8),LRLLOC=$P($G(^(0)),"^",7)
;S LRPRAC=$P($G(^VA(200,PTR,0)),"^")
S LRPRAC=""
I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^LRO(69,LRODT,1,LRSN,0),U,6)
;
S PTR=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",10)
;
S LRUID=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
;
S STR=$G(^VA(200,DUZ,0))
S LRUSI=$P(STR,"^",2)
S LRUSNM=$P(STR,"^")
;
S BLRPARAM=""
Q "OK"
;
PCCVFILE(LRAA,LRAS,LRCDT,LRSS,PCCVISIT) ; EP - Try to determine if Accession already in PCC File
NEW BLRVERN,CDTPCC,FOUNDIT,PCCIEN
;
S BLRVERN=$P($P($T(+1),";")," ")
;
S:LRSS="CH" PCCFILE="^AUPNVLAB(""ALR0"","_$C(34)_LRAS_$C(34)_","
S:LRSS="MI" PCCFILE="^AUPNVMIC(""ALR0"","_$C(34)_LRAS_$C(34)_","
;
S LRCDT=$P(LRCDT,".")
S PCCIEN=.9999999,FOUNDIT=0
F S PCCIEN=$O(@(PCCFILE_PCCIEN_")")) Q:PCCIEN<1!(FOUNDIT) D
. S CDTPCC=$P($P($G(^AUPNVLAB(PCCIEN,12)),"^"),".")
. S:CDTPCC=LRCDT FOUNDIT=PCCIEN
;
I FOUNDIT S PCCVISIT=FOUNDIT Q 1
;
Q 0
;
WHYNOT(LRAS,MESSAGE) ; EP - Store Reason why ^BLREVTQ not called
S ^TMP("BLRPCCRR",$J,"NOSEND",LRAS,$H)=MESSAGE
S NOTSENT=NOTSENT+1
;
D WHYNCNTM(MESSAGE)
;
Q:AUTOLOAD "Q"
;
;W !,?4,"Could not set a variable"
;W $S($L(LRAS):" for Accession "_LRAS_".",1:"."),!
;W ?9,"Error Message:",$E(MESSAGE,1,55),!
;D PRESSKEY^BLRGMENU(14)
Q "Q"
;
WHYNCNTM(MESSAGE) ; EP - Just count messages
S MESSAGE=$$UP^XLFSTR(MESSAGE)
;
I MESSAGE["PCC VISIT",MESSAGE["MATCHED",MESSAGE["COLLECTION DATE" D CNTERRS("PCC VISIT FOUND") Q
I MESSAGE["ACCESSION STRING DOES NOT EXIST" D CNTERRS("ACCESSION STRING DOES NOT EXIST") Q
I MESSAGE["ACCESSION ALREADY IN ^BLRTXLOG" D CNTERRS("ACCESSION ALREADY IN ^BLRTXLOG") Q
I MESSAGE["ACCESSION NOT 'CH' NOR 'MI' SUBSCRIPT" D CNTERRS("ACCESSION NOT 'CH' NOR 'MI' SUBSCRIPT") Q
I MESSAGE["ORDER NUMBER DOES NOT EXIST" D CNTERRS("ORDER NUMBER DOES NOT EXIST") Q
I MESSAGE["NO 'RESULTS AVAILABLE' DATE" D CNTERRS("NO 'RESULTS AVAILABLE' DATE") Q
I MESSAGE["ORDER NUMBER",MESSAGE["ORDER DATE DOES NOT EXIST" D CNTERRS("ORDER DATE DOES NOT EXIST") Q
I MESSAGE["ORDER DATE'S",MESSAGE["DOES NOT EXIST" D CNTERRS("LRSN DOES NOT EXIST") Q
;
D CNTERRS(MESSAGE)
Q
;
CNTERRS(ERRMSG) ; EP
S ^TMP("BLRPCCRR",$J,"ERRCNTS",ERRMSG)=1+$G(^TMP("BLRPCCRR",$J,"ERRCNTS",ERRMSG))
Q
;
BLRAGUT1 ; IHS/MSC/SAT - Fix for Downed PCC Linker (Utilities) ; [ 07/16/2012 4:00 PM ]
+1 ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
+2 ;
+3 ;
SETUP() ;
+1 SET NOTSENT=0
+2 SET AUTOLOAD=0
+3 SET YEARAGO=$$FMADD^XLFDT($$NOW^XLFDT(),-365)
+4 QUIT $$SETVARS()
+5 ;
SETVARS() ; EP - Set the necessary variables for BLREVTQ to work
+1 ; Get Accession
SET LRAS=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+2 IF $LENGTH(LRAS)<1
QUIT $$WHYNOT("<NULL>","Accession string does not exist")
+3 ;
+4 IF +$ORDER(^BLRTXLOG("D",LRAS,0))
QUIT $$WHYNOT(LRAS,"Accession already in ^BLRTXLOG")
+5 ;
+6 SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)
+7 IF LRSS'="CH"&(LRSS'="MI")
QUIT $$WHYNOT(LRAS,"Accession not 'CH' nor 'MI' Subscript")
+8 ;
+9 ; Original Accession Date
SET ORIGACCD=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3)
+10 IF ORIGACCD<YEARAGO
QUIT $$WHYNOT(LRAS,"Original Accession Date More than a Year Ago")
+11 ;
+12 ; Order Number
SET ORDNUM=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
+13 IF ORDNUM<1
QUIT $$WHYNOT(LRAS,"Order Number does not exist")
+14 ;
+15 IF +$GET(LRODT)<1
SET LRODT=+$ORDER(^LRO(69,"C",ORDNUM,0))
+16 IF LRODT<1
QUIT $$WHYNOT(LRAS,"Order Number "_ORDNUM_"'s Order Date does not exist for "_LRAD_" Accession Date")
+17 ;
+18 IF +$GET(LRSN)<1
SET LRSN=+$ORDER(^LRO(69,"C",ORDNUM,LRODT,0))
+19 IF LRSN<1
QUIT $$WHYNOT(LRAS,"Order Date's LRSN:"_LRSN_" does not exist")
+20 ;
+21 ;S DTTRAVIL=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",4) ; Date/Time Results Available
+22 ;I +DTTRAVIL<1 Q $$WHYNOT(LRAS,"No 'Results Available' Date")
+23 ;
+24 ; Collection Date/Time
SET LRCDT=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+25 ;
+26 IF $$PCCVFILE(LRAA,LRAS,LRCDT,LRSS,.PCCVISIT)
QUIT $$WHYNOT(LRAS,"PCC Visit "_PCCVISIT_" Matched "_$PIECE(LRCDT,".")_" Collection Date.")
+27 ; Inverse Date
SET (D0,DA,LRIDT)=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+28 ;
+29 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+30 SET DFN=+$PIECE($GET(^LR(LRDFN,0)),"^",3)
+31 IF DFN<1
QUIT $$WHYNOT(LRAS,"LRDFN "_LRDFN_" has no DFN.")
+32 ;
+33 DO DFN^LRDAGE(DFN,2,LRCDT)
+34 SET (BID,HRCN,PID)=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),"^",2)
+35 SET PNM=$PIECE($GET(^DPT(DFN,0)),"^")
SET STR=$REVERSE($PIECE($GET(^(0)),"^",9))
+36 SET SSN=$REVERSE($EXTRACT(STR,7,9))_"-"_$REVERSE($EXTRACT(STR,5,6))_"-"_$REVERSE($EXTRACT(STR,1,4))
+37 ;
+38 SET BLRCMF="M"
SET BLRDH=+$HOROLOG
SET BLRLOG=1
SET BLRPCC=1
+39 ;S BLROPT="BYPASS" ; Set to BYPASS because its already resulted
+40 ;S BLRPHASE="R" ; Set phase to RESULTing
+41 SET BLRQSITE=DUZ(2)
SET BLRQUIET=1
SET BLRSTOP=0
+42 SET (BLRIDS,LRACC)=LRAS
+43 ;
+44 SET STR=$$FMTE^XLFDT(LRCDT,"2M")
+45 SET LRDAT=$PIECE(STR,"/",1,2)_" "_$TRANSLATE($PIECE(STR,"@",2),":")_"d"
+46 ;
+47 SET (LRACD,LRAOD)=LRAD
+48 SET LRDT0=$$HTE^XLFDT($HOROLOG,"2D")
+49 SET LRLABKY="1^1^1^1"
+50 SET LRLOCKER="^LR("_LRDFN_","_$CHAR(34)_LRSS_$CHAR(34)_","_LRIDT_")"
+51 SET LROUTINE=9
SET LRPANEL=0
SET LRPCEVSO=1
+52 ;
+53 SET PTR=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
SET LRLLOC=$PIECE($GET(^(0)),"^",7)
+54 ;S LRPRAC=$P($G(^VA(200,PTR,0)),"^")
+55 SET LRPRAC=""
+56 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET LRPRAC=$PIECE(^LRO(69,LRODT,1,LRSN,0),U,6)
+57 ;
+58 SET PTR=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",10)
+59 ;
+60 SET LRUID=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+61 ;
+62 SET STR=$GET(^VA(200,DUZ,0))
+63 SET LRUSI=$PIECE(STR,"^",2)
+64 SET LRUSNM=$PIECE(STR,"^")
+65 ;
+66 SET BLRPARAM=""
+67 QUIT "OK"
+68 ;
PCCVFILE(LRAA,LRAS,LRCDT,LRSS,PCCVISIT) ; EP - Try to determine if Accession already in PCC File
+1 NEW BLRVERN,CDTPCC,FOUNDIT,PCCIEN
+2 ;
+3 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+4 ;
+5 IF LRSS="CH"
SET PCCFILE="^AUPNVLAB(""ALR0"","_$CHAR(34)_LRAS_$CHAR(34)_","
+6 IF LRSS="MI"
SET PCCFILE="^AUPNVMIC(""ALR0"","_$CHAR(34)_LRAS_$CHAR(34)_","
+7 ;
+8 SET LRCDT=$PIECE(LRCDT,".")
+9 SET PCCIEN=.9999999
SET FOUNDIT=0
+10 FOR
SET PCCIEN=$ORDER(@(PCCFILE_PCCIEN_")"))
IF PCCIEN<1!(FOUNDIT)
QUIT
Begin DoDot:1
+11 SET CDTPCC=$PIECE($PIECE($GET(^AUPNVLAB(PCCIEN,12)),"^"),".")
+12 IF CDTPCC=LRCDT
SET FOUNDIT=PCCIEN
End DoDot:1
+13 ;
+14 IF FOUNDIT
SET PCCVISIT=FOUNDIT
QUIT 1
+15 ;
+16 QUIT 0
+17 ;
WHYNOT(LRAS,MESSAGE) ; EP - Store Reason why ^BLREVTQ not called
+1 SET ^TMP("BLRPCCRR",$JOB,"NOSEND",LRAS,$HOROLOG)=MESSAGE
+2 SET NOTSENT=NOTSENT+1
+3 ;
+4 DO WHYNCNTM(MESSAGE)
+5 ;
+6 IF AUTOLOAD
QUIT "Q"
+7 ;
+8 ;W !,?4,"Could not set a variable"
+9 ;W $S($L(LRAS):" for Accession "_LRAS_".",1:"."),!
+10 ;W ?9,"Error Message:",$E(MESSAGE,1,55),!
+11 ;D PRESSKEY^BLRGMENU(14)
+12 QUIT "Q"
+13 ;
WHYNCNTM(MESSAGE) ; EP - Just count messages
+1 SET MESSAGE=$$UP^XLFSTR(MESSAGE)
+2 ;
+3 IF MESSAGE["PCC VISIT"
IF MESSAGE["MATCHED"
IF MESSAGE["COLLECTION DATE"
DO CNTERRS("PCC VISIT FOUND")
QUIT
+4 IF MESSAGE["ACCESSION STRING DOES NOT EXIST"
DO CNTERRS("ACCESSION STRING DOES NOT EXIST")
QUIT
+5 IF MESSAGE["ACCESSION ALREADY IN ^BLRTXLOG"
DO CNTERRS("ACCESSION ALREADY IN ^BLRTXLOG")
QUIT
+6 IF MESSAGE["ACCESSION NOT 'CH' NOR 'MI' SUBSCRIPT"
DO CNTERRS("ACCESSION NOT 'CH' NOR 'MI' SUBSCRIPT")
QUIT
+7 IF MESSAGE["ORDER NUMBER DOES NOT EXIST"
DO CNTERRS("ORDER NUMBER DOES NOT EXIST")
QUIT
+8 IF MESSAGE["NO 'RESULTS AVAILABLE' DATE"
DO CNTERRS("NO 'RESULTS AVAILABLE' DATE")
QUIT
+9 IF MESSAGE["ORDER NUMBER"
IF MESSAGE["ORDER DATE DOES NOT EXIST"
DO CNTERRS("ORDER DATE DOES NOT EXIST")
QUIT
+10 IF MESSAGE["ORDER DATE'S"
IF MESSAGE["DOES NOT EXIST"
DO CNTERRS("LRSN DOES NOT EXIST")
QUIT
+11 ;
+12 DO CNTERRS(MESSAGE)
+13 QUIT
+14 ;
CNTERRS(ERRMSG) ; EP
+1 SET ^TMP("BLRPCCRR",$JOB,"ERRCNTS",ERRMSG)=1+$GET(^TMP("BLRPCCRR",$JOB,"ERRCNTS",ERRMSG))
+2 QUIT
+3 ;
