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

BLRAGUT1.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1. SETUP()   ;
  1.  S NOTSENT=0
  1.  S AUTOLOAD=0
  1.  S YEARAGO=$$FMADD^XLFDT($$NOW^XLFDT(),-365)
  1.  Q $$SETVARS()
  1.  ;
  1. SETVARS() ; EP - Set the necessary variables for BLREVTQ to work
  1.  S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))    ; Get Accession
  1.  I $L(LRAS)<1 Q $$WHYNOT("<NULL>","Accession string does not exist")
  1.  ;
  1.  I +$O(^BLRTXLOG("D",LRAS,0)) Q $$WHYNOT(LRAS,"Accession already in ^BLRTXLOG")
  1.  ;
  1.  S LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
  1.  I LRSS'="CH"&(LRSS'="MI") Q $$WHYNOT(LRAS,"Accession not 'CH' nor 'MI' Subscript")
  1.  ;
  1.  S ORIGACCD=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3)  ; Original Accession Date
  1.  I ORIGACCD<YEARAGO Q $$WHYNOT(LRAS,"Original Accession Date More than a Year Ago")
  1.  ;
  1.  S ORDNUM=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))  ; Order Number
  1.  I ORDNUM<1 Q $$WHYNOT(LRAS,"Order Number does not exist")
  1.  ;
  1.  S:+$G(LRODT)<1 LRODT=+$O(^LRO(69,"C",ORDNUM,0))
  1.  I LRODT<1 Q $$WHYNOT(LRAS,"Order Number "_ORDNUM_"'s Order Date does not exist for "_LRAD_" Accession Date")
  1.  ;
  1.  S:+$G(LRSN)<1 LRSN=+$O(^LRO(69,"C",ORDNUM,LRODT,0))
  1.  I LRSN<1 Q $$WHYNOT(LRAS,"Order Date's LRSN:"_LRSN_" does not exist")
  1.  ;
  1.  ;S DTTRAVIL=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",4)     ; Date/Time Results Available
  1.  ;I +DTTRAVIL<1 Q $$WHYNOT(LRAS,"No 'Results Available' Date")
  1.  ;
  1.  S LRCDT=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))                  ; Collection Date/Time
  1.  ;
  1.  I $$PCCVFILE(LRAA,LRAS,LRCDT,LRSS,.PCCVISIT) Q $$WHYNOT(LRAS,"PCC Visit "_PCCVISIT_" Matched "_$P(LRCDT,".")_" Collection Date.")
  1.  S (D0,DA,LRIDT)=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5) ; Inverse Date
  1.  ;
  1.  S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  S DFN=+$P($G(^LR(LRDFN,0)),"^",3)
  1.  I DFN<1 Q $$WHYNOT(LRAS,"LRDFN "_LRDFN_" has no DFN.")
  1.  ;
  1.  D DFN^LRDAGE(DFN,2,LRCDT)
  1.  S (BID,HRCN,PID)=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),"^",2)
  1.  S PNM=$P($G(^DPT(DFN,0)),"^"),STR=$RE($P($G(^(0)),"^",9))
  1.  S SSN=$RE($E(STR,7,9))_"-"_$RE($E(STR,5,6))_"-"_$RE($E(STR,1,4))
  1.  ;
  1.  S BLRCMF="M",BLRDH=+$H,BLRLOG=1,BLRPCC=1
  1.  ;S BLROPT="BYPASS"                            ; Set to BYPASS because its already resulted
  1.  ;S BLRPHASE="R"                               ; Set phase to RESULTing
  1.  S BLRQSITE=DUZ(2),BLRQUIET=1,BLRSTOP=0
  1.  S (BLRIDS,LRACC)=LRAS
  1.  ;
  1.  S STR=$$FMTE^XLFDT(LRCDT,"2M")
  1.  S LRDAT=$P(STR,"/",1,2)_" "_$TR($P(STR,"@",2),":")_"d"
  1.  ;
  1.  S (LRACD,LRAOD)=LRAD
  1.  S LRDT0=$$HTE^XLFDT($H,"2D")
  1.  S LRLABKY="1^1^1^1"
  1.  S LRLOCKER="^LR("_LRDFN_","_$C(34)_LRSS_$C(34)_","_LRIDT_")"
  1.  S LROUTINE=9,LRPANEL=0,LRPCEVSO=1
  1.  ;
  1.  S PTR=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8),LRLLOC=$P($G(^(0)),"^",7)
  1.  ;S LRPRAC=$P($G(^VA(200,PTR,0)),"^")
  1.  S LRPRAC=""
  1.  I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^LRO(69,LRODT,1,LRSN,0),U,6)
  1.  ;
  1.  S PTR=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",10)
  1.  ;
  1.  S LRUID=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1.  ;
  1.  S STR=$G(^VA(200,DUZ,0))
  1.  S LRUSI=$P(STR,"^",2)
  1.  S LRUSNM=$P(STR,"^")
  1.  ;
  1.  S BLRPARAM=""
  1.  Q "OK"
  1.  ;
  1. PCCVFILE(LRAA,LRAS,LRCDT,LRSS,PCCVISIT) ; EP - Try to determine if Accession already in PCC File
  1.  NEW BLRVERN,CDTPCC,FOUNDIT,PCCIEN
  1.  ;
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  ;
  1.  S:LRSS="CH" PCCFILE="^AUPNVLAB(""ALR0"","_$C(34)_LRAS_$C(34)_","
  1.  S:LRSS="MI" PCCFILE="^AUPNVMIC(""ALR0"","_$C(34)_LRAS_$C(34)_","
  1.  ;
  1.  S LRCDT=$P(LRCDT,".")
  1.  S PCCIEN=.9999999,FOUNDIT=0
  1.  F  S PCCIEN=$O(@(PCCFILE_PCCIEN_")"))  Q:PCCIEN<1!(FOUNDIT)  D
  1.  . S CDTPCC=$P($P($G(^AUPNVLAB(PCCIEN,12)),"^"),".")
  1.  . S:CDTPCC=LRCDT FOUNDIT=PCCIEN
  1.  ;
  1.  I FOUNDIT S PCCVISIT=FOUNDIT  Q 1
  1.  ;
  1.  Q 0
  1.  ;
  1. WHYNOT(LRAS,MESSAGE) ; EP - Store Reason why ^BLREVTQ not called
  1.  S ^TMP("BLRPCCRR",$J,"NOSEND",LRAS,$H)=MESSAGE
  1.  S NOTSENT=NOTSENT+1
  1.  ;
  1.  D WHYNCNTM(MESSAGE)
  1.  ;
  1.  Q:AUTOLOAD "Q"
  1.  ;
  1.  ;W !,?4,"Could not set a variable"
  1.  ;W $S($L(LRAS):" for Accession "_LRAS_".",1:"."),!
  1.  ;W ?9,"Error Message:",$E(MESSAGE,1,55),!
  1.  ;D PRESSKEY^BLRGMENU(14)
  1.  Q "Q"
  1.  ;
  1. WHYNCNTM(MESSAGE) ; EP - Just count messages
  1.  S MESSAGE=$$UP^XLFSTR(MESSAGE)
  1.  ;
  1.  I MESSAGE["PCC VISIT",MESSAGE["MATCHED",MESSAGE["COLLECTION DATE" D CNTERRS("PCC VISIT FOUND")  Q
  1.  I MESSAGE["ACCESSION STRING DOES NOT EXIST" D CNTERRS("ACCESSION STRING DOES NOT EXIST")  Q
  1.  I MESSAGE["ACCESSION ALREADY IN ^BLRTXLOG" D CNTERRS("ACCESSION ALREADY IN ^BLRTXLOG")  Q
  1.  I MESSAGE["ACCESSION NOT 'CH' NOR 'MI' SUBSCRIPT" D CNTERRS("ACCESSION NOT 'CH' NOR 'MI' SUBSCRIPT")  Q
  1.  I MESSAGE["ORDER NUMBER DOES NOT EXIST" D CNTERRS("ORDER NUMBER DOES NOT EXIST")  Q
  1.  I MESSAGE["NO 'RESULTS AVAILABLE' DATE" D CNTERRS("NO 'RESULTS AVAILABLE' DATE")  Q
  1.  I MESSAGE["ORDER NUMBER",MESSAGE["ORDER DATE DOES NOT EXIST" D CNTERRS("ORDER DATE DOES NOT EXIST")  Q
  1.  I MESSAGE["ORDER DATE'S",MESSAGE["DOES NOT EXIST" D CNTERRS("LRSN DOES NOT EXIST")  Q
  1.  ;
  1.  D CNTERRS(MESSAGE)
  1.  Q
  1.  ;
  1. CNTERRS(ERRMSG) ; EP
  1.  S ^TMP("BLRPCCRR",$J,"ERRCNTS",ERRMSG)=1+$G(^TMP("BLRPCCRR",$J,"ERRCNTS",ERRMSG))
  1.  Q
  1.  ;