LRAPUTL ;DALOI/STAFF - AP UTILITIES ;06/21/12 12:06
;;5.2;LAB SERVICE;**259,308,350**;Sep 27, 1994;Build 230
;
; Reference to EXTRACT^TIULQ supported by IA #2693
; Reference to ADM^VADPT2 supported by DBIA #325
;
Q
;
;
ACCYR(LRYROUT,LRYRIN,LRAREA,LRAANM) ;
; Return variable (passed by reference):
; LRYROUT = Accession Year LRAD^LRH(0)
; where LRAD is format 3010000
; LRH(0) is format 2001
; = -1 - Error Condition
; = 0 - No change from default value (LRYRIN)
;
; Input parameters:
; LRYRIN = Default accession year in yyyy format
; LRAREA = Accession Area Mnemonic (ex. AU,CY,EM,SP)
; LRAANM = Accession Area Name (ex. SURGICAL PATHOLOGY)
;
S LRYROUT=-1
Q:LRAREA=""!(LRYRIN="")!(LRAANM="")
N LRYR1,LRYR2,%DT
W !!,"Data entry for ",LRYRIN," "
S %=1 D YN^LRU
I %<1 D END Q
I %=1 S LRYROUT=0 K LRYRIN,LRAREA,LRAANM Q
I %=2 D I Y<1 D END Q
. S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT
. Q:Y<1
. S LRYR1=$E(Y,1,3)_"0000",LRYR2=$E(Y,1,3)+1700
I '$O(^LRO(68,LRAREA,1,LRYR1,1,0)) D Q
. W $C(7),!!,"NO ",LRAANM," ACCESSIONS IN FILE FOR ",LRYR2,!!
. S LRYROUT=-1
. D END
S LRYROUT=LRYR1_U_LRYR2
Q
;
;
LOOKUP(LRDATA,LRYR1,LRAANM,LRAREA,LRYR2,LRAAN) ;
; Call with LRDATA = array to return data (pass by reference)
; LRYR1 = Year portion of accession date , i.e. 2009
; LRAANM = Accession area name
; LRAREA = File #63 subscript
; LRYR2 = FileMan accession date
; LRAAN = Accession number
; Lookup by accession number or patient name or UID
N STOP,X,Y,DIR
; preserve if caller sets LRSEL, some expect LRSEL back
I $D(LRSEL) N LRSEL
K LR("CK"),LRIDT
S (STOP,LREND)=0
S LRDATA=0 W !
S LRSEL=$$SELBY("Select one")
I 'LRSEL S LRDATA=-1 S LREND=1 D END Q
;
; Select by accession number
I LRSEL=1 D I STOP D END Q
. S DIR(0)="NO",DIR("A")="Enter Accession Number"
. S DIR("?")="Enter the year "_LRYR1_" "_LRAANM_" accession number to be updated"
. D ^DIR S LRAN=Y K DIR
. I LRAN=""!(LRAN[U) S LRDATA=-1 S STOP=1 S LREND=1
;
; Select by patient name
I LRSEL=3 D I STOP D END Q
. S DIR(0)="FO",DIR("A")="Enter Patient Name"
. S DIR("?")="Locate the accession by entering the patient name."
. D ^DIR S LRPNM=Y K DIR
. I LRPNM=""!(LRPNM[U) S LRDATA=-1 S STOP=1 S LREND=1 Q
. D PNAME^LRAPDA
. I LRAN<1 S STOP=1 Q
. S LRDATA=LRDFN,LRDATA(1)=$S('LRAU:LRI,1:"")
;
; Select by UID
I LRSEL=2 D Q:LRUID=""
. N LRQUIT
. S LRQUIT=0
. F D Q:LRQUIT
. . S LRUID="" D UID^LRVERA
. . I LRUID="" S LRQUIT=1 Q
. . I LRAA=LRAAN,LRAD=LRYR2 S LRQUIT=1 Q
. . W !!,$C(7),"UID: ",LRUID," not associated with Accession Area: ",LRAANM,!,?32,"and Accession Year: ",LRYR1,!
;
D OE1^LR7OB63D
W " for "_LRYR1
I '$D(^LRO(68,LRAAN,1,LRYR2,1,LRAN,0)) D Q
. S MSG="Accession # "_LRAN_" for "_LRYR1_" not in "_LRAANM
. D EN^DDIOL(MSG,"","!!") K MSG
. S LRDATA=-1
;
S LRAA=LRAAN,LRAD=LRYR2
S X=^LRO(68,LRAAN,1,LRYR2,1,LRAN,0),LRDFN=+X
S LRODT=$P(X,U,4)
Q:'$D(^LR(LRDFN,0)) S X=^LR(LRDFN,0) D ^LRUP
W @IOF
W !?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
S (LRIDT,LRI)=+$P($G(^LRO(68,LRAAN,1,LRYR2,1,LRAN,3)),"^",5)
S LRORU3=$G(^LRO(68,LRAAN,1,LRYR2,1,LRAN,.3))
I LRAREA'="AU",'$D(^LR(LRDFN,LRAREA,LRI,0)) D Q
. W $C(7)
. S MSG(1)="Inverse date missing or incorrect in Accession Area file for"
. S MSG(1,"F")="!"
. S MSG(2)=LRAANM_" Year: "_$E(LRYR2,2,3)_" Accession: "_LRAN
. S MSG(2,"F")="!"
. D EN^DDIOL(.MSG) K MSG
. S LRDATA=-1
D DEMGRPH(LRAN,LRAD,LRAA)
S LRDATA=LRDFN,LRDATA(1)=LRI
Q
;
;
DEMGRPH(LRAN,LRAD,LRAA) ; Demographics
N LRIENS,DA,LRIDT,LRQUIT,LRSPECID,LREDT,LRB
S LRQUIT=0
S LRIENS=LRAN_","_LRAD_","_LRAA_","
S LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRIENS,15,"E")
S LRSPECID=LRSPECID_" ["_$$GET1^DIQ(68.02,LRIENS,16)_"]"
S LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
S LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
W !?5,"Collection Date: "_$S(LREDT:$$FMTE^XLFDT(LREDT,1),1:"<None on file>")
W !?10,LRSPECID,!
I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) W !?15,"PCE ENC # "_^("PCE")
I $G(LRSS)'="",$O(^LR(LRDFN,LRSS,LRIDT,.1,0)) D
. N LRX
. W !?5,"Tissue Specimen(s): ",!
. S LRX=0 F S LRX=$O(^LR(LRDFN,LRSS,LRIDT,.1,LRX)) Q:LRX<1!(LRQUIT) D
. . I $Y>(IOSL-10) D PG Q:$G(LRQUIT) D
. . . W @IOF,!?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1),!
. . W ?15,$P($G(^LR(LRDFN,LRSS,LRIDT,.1,LRX,0)),U),!
I $O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) D
. W ?5,"Test(s): "
. S LRX=0
. F S LRX=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX)) Q:LRX<1!($G(LRQUIT)) D
. . I $Y>(IOSL-10) D PG Q:$G(LRQUIT) W @IOF
. . W ?15,$P($G(^LAB(60,+LRX,0)),U)," ",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX,0),U,6),!
S LRB=0
F S LRB=$O(^LR(LRDFN,LRSS,LRIDT,99,LRB)) Q:'LRB D
. W !,"COMMENTS:",^LR(LRDFN,LRSS,LRIDT,99,LRB,0)
;
Q
;
;
GETDOCS(LRDOCS,LRDFN,LRSS,LRI,LRSF) ; Return PCP(inpatient PC/attending/outpt PC/outpt assoc PC/outpt attending) and ordering provider
N DFN,LRDPF,LRIENS,LRFLD,LRPROVIDER,LRX,X
S:LRSS="AU" LRSF=63
S LRDOCS=0
I '+$G(LRDFN)!($G(LRSS)="")!('+$G(LRSF)) Q
I "AUSPCYEM"'[LRSS Q
;
I LRSS'="AU" S LRIENS=LRI_","_LRDFN,LRFLD=.07
E S LRIENS=LRDFN_",",LRFLD=12.1
S LRPROVIDER=$$GET1^DIQ(LRSF,LRIENS,LRFLD,"I")
I LRPROVIDER>0 S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=LRPROVIDER_"^"_$$NAME^XUSER(LRPROVIDER,"F")_"^Ordering Provider"
;
S LRDPF=$P($G(^LR(LRDFN,0)),"^",2),DFN=$P($G(^LR(LRDFN,0)),"^",3)
I LRDPF'=2 Q
;
N LRDT,VADMVT,VAINDT
I LRSS="AU" S LRDT=$P($G(^LR(LRDFN,"AU")),"^")
E S LRDT=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^")
I LRDT<1 S LRDT=DT
S VAINDT=LRDT D ADM^VADPT2
I VADMVT D
. N VAHOW,VAIN,VAROOT
. D INP^VADPT
. I VAIN(2) S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=+VAIN(2)_"^"_$$NAME^XUSER(+VAIN(2),"F")_"^Inpatient Primary Care Provider"
. I VAIN(11) S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=+VAIN(11)_"^"_$$NAME^XUSER(+VAIN(11),"F")_"^Inpatient Attending Provider"
S LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,1)
I LRX>0 S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=+LRX_"^"_$$NAME^XUSER(+LRX,"F")_"^Outpatient Primary Care Provider"
S LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,2)
I LRX>0 S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=+LRX_"^"_$$NAME^XUSER(+LRX,"F")_"^Outpatient Attending Provider"
;
; Check for surgery case reference and retrieve surgeon and attending
K LRIENS
S LRIENS=LRDFN_","_LRSS_","_LRI_",0"
S LRX=$O(^LR(LRDFN,"EPR","AD",LRIENS,1,0))
I LRX>0 D
. N LRDATA,LRJ,LRREF,LRSRDATA,LRSRTN,LRTITLE
. S LRREF=LRX_","_LRDFN_","
. D GETDATA^LRUEPR(.LRDATA,LRREF)
. S LRSRTN=LRDATA(63.00013,LRREF,1,"I")
. I $P(LRSRTN,";",2)'="SRF(" Q
. D SRCASE^LRUEPR(.LRSRDATA,+LRSRTN)
. I $G(LRSRDATA("ERR")) D Q
. . S LRMD("ERR")=LRSRDATA("ERR")
. . D SRCASERR^LRUEPR(LRREF,LRSRTN,LRSRDATA("ERR"))
. F LRJ=.14,.164,123,124 D
. . S LRX=LRSRDATA(130,+LRSRTN_",",LRJ,"I")
. . I LRX="" Q
. . S LRTITLE=$S(LRJ=.14:"Surgeon",LRJ=.164:"Attending Surgeon",LRJ=123:"Provider",LRJ=124:"Attending Provider",1:"")
. . I LRPROVIDER,LRX=LRPROVIDER S LRDOCS(1)=LRDOCS(1)_"/"_LRTITLE Q
. . S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=LRX_"^"_$$NAME^XUSER(LRX,"F")_"^"_LRTITLE
Q
;
;
RELEASE(LRRELEAS,LRDFN,LRSS,LRI) ;
; Determine if report has been released
N LRFILE,LRFLDS,LRIENS,LRRELAR,LRCT
I '+$G(LRDFN) S LRRELEAS=0 Q
I $G(LRSS)=""!("AUSPEMCY"'[LRSS) S LRRELEAS=0 Q
I LRSS'="AU",'+$G(LRI) S LRRELEAS=0 Q
I LRSS="AU" D
. S LRFILE=63,LRFLDS="14.7;14.8",LRIENS=LRDFN_","
I LRSS'="AU" D
. S LRFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
. S LRFLDS=".11;.13;.15"
. S LRIENS=LRI_","_LRDFN_","
Q:LRFILE=""
D GETS^DIQ(LRFILE,LRIENS,LRFLDS,"I","LRRELAR")
F LRCT=1:1:$S(LRSS="AU":2,1:3) D
. S LRRELEAS(LRCT)=+$G(LRRELAR(LRFILE,LRIENS,$P(LRFLDS,";",LRCT),"I"))
Q
;
;
TIUCHK(LRPTR,LRDFN,LRSS,LRI) ;
; Check to see if report is in TIU
N LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL
I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q
I LRSS="AU" D
. S LRROOT="^LR(LRDFN,101,""A"")",LRIENS=LRDFN_","
. S LRFILE=63.101
I LRSS'="AU" D
. S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""A"")"
. S LRIENS=LRI_","_LRDFN_","
. S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
S LRTREC=$O(@(LRROOT),-1)
I LRFILE=""!(LRTREC="") S LRPTR=0 Q
S LRIENS=LRTREC_","_LRIENS
S LRPTR=+$$GET1^DIQ(LRFILE,LRIENS,1,"I")
S:LRPTR LRPTR("D")=+$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
I LRSS="AU" D
. S LRFILE=63,LRIENS=LRDFN_",",LRFLD=14.7
I LRSS'="AU" D
. S LRFLD=$S(LRSS="CY":9,LRSS="SP":8,LRSS="EM":2,1:"")
. Q:LRFLD=""
. S LRFILE=+$$GET1^DID(63,LRFLD,"","SPECIFIER"),LRFLD=.11
. Q:LRFILE=""
. S LRIENS=LRI_","_LRDFN_","
S LRREL=+$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"I")
I 'LRREL K LRPTR S LRPTR=0 Q
I LRREL'=+$G(LRPTR("D")) K LRPTR S LRPTR=0
Q
;
;
ESIGINF(LRESINF,LRDFN,LRSS,LRI) ;Return Esig Info
N LRTIUDA,LRESINF1
Q:'$D(LRDFN)!('$D(LRSS))
Q:LRSS=""!("AUSPEMCY"'[LRSS)
D TIUCHK(.LRTIUDA,LRDFN,LRSS,$G(LRI))
Q:'+$G(LRTIUDA)
D EXTRACT^TIULQ(LRTIUDA,"LRESINF1(""ESIG"")",,,,,,1)
Q:'$D(LRESINF1("ESIG",LRTIUDA))
S LRESINF(1)=$G(LRESINF1("ESIG",LRTIUDA,1501,"E"))
S LRESINF(2)=$G(LRESINF1("ESIG",LRTIUDA,1503,"E"))
Q
;
;
NEWLN(LRTEXT,TAB) ;
S LCT=$G(LCT)+1,BTAB=0
S TAB=+TAB
D GLBWRT(LRTEXT,TAB)
Q
;
;
GLBWRT(LRTEXT,TAB) ;Write to global
D GLB(LCT,TAB,BTAB,LRTEXT,GROOT,.ATAB)
S BTAB=ATAB
Q
;
;
GLB(LINE,TAB,BTAB,TEXT,ROOT,ATAB) ;
; This subroutine is used to store report text to a global.
; Input variables:
; LINE = Current line number
; TAB = Desired tab position (not required)
; BTAB = Current tab position BEFORE text is stored
; TEXT = Text string to be stored
; ROOT = Global root
;
; Output variables:
; ATAB = Current tab position after text storage
;
N LRSPC,LRINC,FTEXT,LRLINE
S LRSPC="" F LRINC=1:1:80 S LRSPC=LRSPC_" "
S:BTAB="" BTAB=0
S:+TAB=0 TAB=BTAB
S FTEXT=TEXT
I TAB,TAB>BTAB S FTEXT=$E(LRSPC,1,TAB-BTAB)_TEXT
S:'$D(@(ROOT_"0)")) @(ROOT_"0)")="^^^^"_DT_"^"
S LRLINE=LINE,LINE=LINE_",0"
S:'$D(@(ROOT_LINE_")")) @(ROOT_LINE_")")=""
S @(ROOT_LINE_")")=@(ROOT_LINE_")")_FTEXT
S $P(@(ROOT_"0)"),"^",3,4)=LRLINE_"^"_LRLINE
S ATAB=TAB+$L(TEXT)
Q
;
;
PROVIDR ; Entry of provider taken from PRO^LRCAPES
S LREND=0
D
. N LRPRONM,DIR,DIRUT,DUOUT,X,Y
. S LRPRONM=$$GET1^DIQ(200,+$G(LRPRO),.01,"I")
. I $L(LRPRONM),$D(^VA(200,"AK.PROVIDER",LRPRONM,+$G(LRPRO)))#2,$$GET^XUA4A72(+$G(LRPRO),DT)>0 S DIR("B")=LRPRONM
. S DIR("A")="Provider"
. S LRPRO=0,DIR(0)="PO^200:ENMZ"
. S DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U),+Y)),$$GET^XUA4A72(+Y,DT)>0"
. D ^DIR
. I Y>1 S LRPRO=+Y
I '$G(LRPRO) D D END^LRCAPES Q
. W !?5,"No Active Provider Selected",!
. S LRNOP=1
. S LRQUIT=1
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 D D END^LRCAPES
. W !?5,"The accession is corrupt - missing zero node",!
. S LRNOP="7^Corrupt Accession"
. S LRQUIT=1
Q
;
;
REFRRL ; Display informational message on referrals
N LRMSG
S LRMSG(1)=$$CJ^XLFSTR("*** NOTE: This "_$P(^DIC(LRDPF,0),"^")_" report will not be stored in TIU",IOM),LRMSG(1,"F")="!!"
S LRMSG(2)=$$CJ^XLFSTR("and therefore does not have an electronic signature.",IOM)
S LRMSG(3)=$$CJ^XLFSTR("A hardcopy signature will be required for this report.",IOM)
D EN^DDIOL(.LRMSG)
Q
;
;
PG ; Page break
N DIR,DIRUT,DUOUT,DTOUT
S DIR(0)="E" D ^DIR
I $G(DIRUT) S LRQUIT=1
Q
;
;
END ;
K LRYRIN,LRAREA,LRAANM
Q
;
;
SELBY(X1) ; Select by accession number or unique identifier(UID) or patient name
; Call with X1= message prompt
; Returns Y=0 (abort)
; =1 (accession number)
; =2 (unique identifier)
; =3 (patient name)
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SO^1:Accession number;2:Unique Identifier (UID);3:Patient Name",DIR("A")=X1
S X=$$GET^XPAR("USR^DIV^PKG","LR AP REPORT SELECTION",1,"Q")
S DIR("B")=$S(X:X,1:1)
D ^DIR
I $D(DIRUT) S Y=0
Q Y
;
;
GETPCP(LRPCP,LRDFN,LRSS,LRIDT) ; Return PCP(inpatient PC/attending/outpt PC)
;
; Call with LRPCP = primary care provider array (pass by reference)
; LRDFN = internal entry in file #63
; LRSS = file #63 subscript
; LRIDT = file #63 specimen inverse date/time
;
; Returns LRPCP = IEN of provider in file #200 (0 if none)
; LRPCP(1) = standardized formatted name (null if none)
;
N DFN,LRDPF,LRDT,LRX,VADMVT,VAINDT
;
S LRPCP=0,LRPCP(1)=""
I +$G(LRDFN)<0 Q
;
I LRSS'?1(1"SP",1"CY",1"EM",1"AU") Q
;
S LRDPF=$P($G(^LR(LRDFN,0)),"^",2),DFN=$P($G(^LR(LRDFN,0)),"^",3)
I LRDPF'=2 Q
;
; Retreive specimen collection date/time otherwise default to today
I LRSS="AU" S LRDT=$P($G(^LR(LRDFN,"AU")),"^")
E S LRDT=$P($G(^LR(LRDFN,LRSS,LRIDT,0)),"^")
I LRDT<1 S LRDT=DT
;
; Check if patient was inpatient on specimen date/time
; and retrieve inpatient primary care provider (VAIN(2)) or attending (VAIN(11))
S VAINDT=LRDT D ADM^VADPT2
I VADMVT D
. N VAHOW,VAIN,VAROOT
. D INP^VADPT
. I VAIN(2) S LRPCP=+VAIN(2) Q
. I VAIN(11) S LRPCP=+VAIN(11)
;
; If no inpatient primary care/attending then check for outpatient PCP
; 1 - PC Practitioner
; then 2 - Attending
I LRPCP<1 D
. S LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,1)
. I LRX>0 S LRPCP=+LRX Q
. S LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,2)
. I LRX>0 S LRPCP=+LRX Q
;
; If primary care provider then return formatted name
I LRPCP D
. N LRNAME
. S LRNAME("FILE")=200,LRNAME("FIELD")=.01,LRNAME("IENS")=LRPCP_","
. S LRPCP(1)=$$NAMEFMT^XLFNAME(.LRNAME,"G","DcMP")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPUTL 13755 printed Sep 23, 2025@19:44:16 Page 2
LRAPUTL ;DALOI/STAFF - AP UTILITIES ;06/21/12 12:06
+1 ;;5.2;LAB SERVICE;**259,308,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; Reference to EXTRACT^TIULQ supported by IA #2693
+4 ; Reference to ADM^VADPT2 supported by DBIA #325
+5 ;
+6 QUIT
+7 ;
+8 ;
ACCYR(LRYROUT,LRYRIN,LRAREA,LRAANM) ;
+1 ; Return variable (passed by reference):
+2 ; LRYROUT = Accession Year LRAD^LRH(0)
+3 ; where LRAD is format 3010000
+4 ; LRH(0) is format 2001
+5 ; = -1 - Error Condition
+6 ; = 0 - No change from default value (LRYRIN)
+7 ;
+8 ; Input parameters:
+9 ; LRYRIN = Default accession year in yyyy format
+10 ; LRAREA = Accession Area Mnemonic (ex. AU,CY,EM,SP)
+11 ; LRAANM = Accession Area Name (ex. SURGICAL PATHOLOGY)
+12 ;
+13 SET LRYROUT=-1
+14 if LRAREA=""!(LRYRIN="")!(LRAANM="")
QUIT
+15 NEW LRYR1,LRYR2,%DT
+16 WRITE !!,"Data entry for ",LRYRIN," "
+17 SET %=1
DO YN^LRU
+18 IF %<1
DO END
QUIT
+19 IF %=1
SET LRYROUT=0
KILL LRYRIN,LRAREA,LRAANM
QUIT
+20 IF %=2
Begin DoDot:1
+21 SET %DT="AE"
SET %DT(0)="-N"
SET %DT("A")="Enter YEAR: "
DO ^%DT
+22 if Y<1
QUIT
+23 SET LRYR1=$EXTRACT(Y,1,3)_"0000"
SET LRYR2=$EXTRACT(Y,1,3)+1700
End DoDot:1
IF Y<1
DO END
QUIT
+24 IF '$ORDER(^LRO(68,LRAREA,1,LRYR1,1,0))
Begin DoDot:1
+25 WRITE $CHAR(7),!!,"NO ",LRAANM," ACCESSIONS IN FILE FOR ",LRYR2,!!
+26 SET LRYROUT=-1
+27 DO END
End DoDot:1
QUIT
+28 SET LRYROUT=LRYR1_U_LRYR2
+29 QUIT
+30 ;
+31 ;
LOOKUP(LRDATA,LRYR1,LRAANM,LRAREA,LRYR2,LRAAN) ;
+1 ; Call with LRDATA = array to return data (pass by reference)
+2 ; LRYR1 = Year portion of accession date , i.e. 2009
+3 ; LRAANM = Accession area name
+4 ; LRAREA = File #63 subscript
+5 ; LRYR2 = FileMan accession date
+6 ; LRAAN = Accession number
+7 ; Lookup by accession number or patient name or UID
+8 NEW STOP,X,Y,DIR
+9 ; preserve if caller sets LRSEL, some expect LRSEL back
+10 IF $DATA(LRSEL)
NEW LRSEL
+11 KILL LR("CK"),LRIDT
+12 SET (STOP,LREND)=0
+13 SET LRDATA=0
WRITE !
+14 SET LRSEL=$$SELBY("Select one")
+15 IF 'LRSEL
SET LRDATA=-1
SET LREND=1
DO END
QUIT
+16 ;
+17 ; Select by accession number
+18 IF LRSEL=1
Begin DoDot:1
+19 SET DIR(0)="NO"
SET DIR("A")="Enter Accession Number"
+20 SET DIR("?")="Enter the year "_LRYR1_" "_LRAANM_" accession number to be updated"
+21 DO ^DIR
SET LRAN=Y
KILL DIR
+22 IF LRAN=""!(LRAN[U)
SET LRDATA=-1
SET STOP=1
SET LREND=1
End DoDot:1
IF STOP
DO END
QUIT
+23 ;
+24 ; Select by patient name
+25 IF LRSEL=3
Begin DoDot:1
+26 SET DIR(0)="FO"
SET DIR("A")="Enter Patient Name"
+27 SET DIR("?")="Locate the accession by entering the patient name."
+28 DO ^DIR
SET LRPNM=Y
KILL DIR
+29 IF LRPNM=""!(LRPNM[U)
SET LRDATA=-1
SET STOP=1
SET LREND=1
QUIT
+30 DO PNAME^LRAPDA
+31 IF LRAN<1
SET STOP=1
QUIT
+32 SET LRDATA=LRDFN
SET LRDATA(1)=$SELECT('LRAU:LRI,1:"")
End DoDot:1
IF STOP
DO END
QUIT
+33 ;
+34 ; Select by UID
+35 IF LRSEL=2
Begin DoDot:1
+36 NEW LRQUIT
+37 SET LRQUIT=0
+38 FOR
Begin DoDot:2
+39 SET LRUID=""
DO UID^LRVERA
+40 IF LRUID=""
SET LRQUIT=1
QUIT
+41 IF LRAA=LRAAN
IF LRAD=LRYR2
SET LRQUIT=1
QUIT
+42 WRITE !!,$CHAR(7),"UID: ",LRUID," not associated with Accession Area: ",LRAANM,!,?32,"and Accession Year: ",LRYR1,!
End DoDot:2
if LRQUIT
QUIT
End DoDot:1
if LRUID=""
QUIT
+43 ;
+44 DO OE1^LR7OB63D
+45 WRITE " for "_LRYR1
+46 IF '$DATA(^LRO(68,LRAAN,1,LRYR2,1,LRAN,0))
Begin DoDot:1
+47 SET MSG="Accession # "_LRAN_" for "_LRYR1_" not in "_LRAANM
+48 DO EN^DDIOL(MSG,"","!!")
KILL MSG
+49 SET LRDATA=-1
End DoDot:1
QUIT
+50 ;
+51 SET LRAA=LRAAN
SET LRAD=LRYR2
+52 SET X=^LRO(68,LRAAN,1,LRYR2,1,LRAN,0)
SET LRDFN=+X
+53 SET LRODT=$PIECE(X,U,4)
+54 if '$DATA(^LR(LRDFN,0))
QUIT
SET X=^LR(LRDFN,0)
DO ^LRUP
+55 WRITE @IOF
+56 WRITE !?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
+57 SET (LRIDT,LRI)=+$PIECE($GET(^LRO(68,LRAAN,1,LRYR2,1,LRAN,3)),"^",5)
+58 SET LRORU3=$GET(^LRO(68,LRAAN,1,LRYR2,1,LRAN,.3))
+59 IF LRAREA'="AU"
IF '$DATA(^LR(LRDFN,LRAREA,LRI,0))
Begin DoDot:1
+60 WRITE $CHAR(7)
+61 SET MSG(1)="Inverse date missing or incorrect in Accession Area file for"
+62 SET MSG(1,"F")="!"
+63 SET MSG(2)=LRAANM_" Year: "_$EXTRACT(LRYR2,2,3)_" Accession: "_LRAN
+64 SET MSG(2,"F")="!"
+65 DO EN^DDIOL(.MSG)
KILL MSG
+66 SET LRDATA=-1
End DoDot:1
QUIT
+67 DO DEMGRPH(LRAN,LRAD,LRAA)
+68 SET LRDATA=LRDFN
SET LRDATA(1)=LRI
+69 QUIT
+70 ;
+71 ;
DEMGRPH(LRAN,LRAD,LRAA) ; Demographics
+1 NEW LRIENS,DA,LRIDT,LRQUIT,LRSPECID,LREDT,LRB
+2 SET LRQUIT=0
+3 SET LRIENS=LRAN_","_LRAD_","_LRAA_","
+4 SET LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRIENS,15,"E")
+5 SET LRSPECID=LRSPECID_" ["_$$GET1^DIQ(68.02,LRIENS,16)_"]"
+6 SET LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
+7 SET LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
+8 WRITE !?5,"Collection Date: "_$SELECT(LREDT:$$FMTE^XLFDT(LREDT,1),1:"<None on file>")
+9 WRITE !?10,LRSPECID,!
+10 IF $GET(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE"))
WRITE !?15,"PCE ENC # "_^("PCE")
+11 IF $GET(LRSS)'=""
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,.1,0))
Begin DoDot:1
+12 NEW LRX
+13 WRITE !?5,"Tissue Specimen(s): ",!
+14 SET LRX=0
FOR
SET LRX=$ORDER(^LR(LRDFN,LRSS,LRIDT,.1,LRX))
if LRX<1!(LRQUIT)
QUIT
Begin DoDot:2
+15 IF $Y>(IOSL-10)
DO PG
if $GET(LRQUIT)
QUIT
Begin DoDot:3
+16 WRITE @IOF,!?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1),!
End DoDot:3
+17 WRITE ?15,$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,.1,LRX,0)),U),!
End DoDot:2
End DoDot:1
+18 IF $ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
Begin DoDot:1
+19 WRITE ?5,"Test(s): "
+20 SET LRX=0
+21 FOR
SET LRX=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX))
if LRX<1!($GET(LRQUIT))
QUIT
Begin DoDot:2
+22 IF $Y>(IOSL-10)
DO PG
if $GET(LRQUIT)
QUIT
WRITE @IOF
+23 WRITE ?15,$PIECE($GET(^LAB(60,+LRX,0)),U)," ",$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX,0),U,6),!
End DoDot:2
End DoDot:1
+24 SET LRB=0
+25 FOR
SET LRB=$ORDER(^LR(LRDFN,LRSS,LRIDT,99,LRB))
if 'LRB
QUIT
Begin DoDot:1
+26 WRITE !,"COMMENTS:",^LR(LRDFN,LRSS,LRIDT,99,LRB,0)
End DoDot:1
+27 ;
+28 QUIT
+29 ;
+30 ;
GETDOCS(LRDOCS,LRDFN,LRSS,LRI,LRSF) ; Return PCP(inpatient PC/attending/outpt PC/outpt assoc PC/outpt attending) and ordering provider
+1 NEW DFN,LRDPF,LRIENS,LRFLD,LRPROVIDER,LRX,X
+2 if LRSS="AU"
SET LRSF=63
+3 SET LRDOCS=0
+4 IF '+$GET(LRDFN)!($GET(LRSS)="")!('+$GET(LRSF))
QUIT
+5 IF "AUSPCYEM"'[LRSS
QUIT
+6 ;
+7 IF LRSS'="AU"
SET LRIENS=LRI_","_LRDFN
SET LRFLD=.07
+8 IF '$TEST
SET LRIENS=LRDFN_","
SET LRFLD=12.1
+9 SET LRPROVIDER=$$GET1^DIQ(LRSF,LRIENS,LRFLD,"I")
+10 IF LRPROVIDER>0
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=LRPROVIDER_"^"_$$NAME^XUSER(LRPROVIDER,"F")_"^Ordering Provider"
+11 ;
+12 SET LRDPF=$PIECE($GET(^LR(LRDFN,0)),"^",2)
SET DFN=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+13 IF LRDPF'=2
QUIT
+14 ;
+15 NEW LRDT,VADMVT,VAINDT
+16 IF LRSS="AU"
SET LRDT=$PIECE($GET(^LR(LRDFN,"AU")),"^")
+17 IF '$TEST
SET LRDT=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),"^")
+18 IF LRDT<1
SET LRDT=DT
+19 SET VAINDT=LRDT
DO ADM^VADPT2
+20 IF VADMVT
Begin DoDot:1
+21 NEW VAHOW,VAIN,VAROOT
+22 DO INP^VADPT
+23 IF VAIN(2)
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=+VAIN(2)_"^"_$$NAME^XUSER(+VAIN(2),"F")_"^Inpatient Primary Care Provider"
+24 IF VAIN(11)
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=+VAIN(11)_"^"_$$NAME^XUSER(+VAIN(11),"F")_"^Inpatient Attending Provider"
End DoDot:1
+25 SET LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,1)
+26 IF LRX>0
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=+LRX_"^"_$$NAME^XUSER(+LRX,"F")_"^Outpatient Primary Care Provider"
+27 SET LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,2)
+28 IF LRX>0
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=+LRX_"^"_$$NAME^XUSER(+LRX,"F")_"^Outpatient Attending Provider"
+29 ;
+30 ; Check for surgery case reference and retrieve surgeon and attending
+31 KILL LRIENS
+32 SET LRIENS=LRDFN_","_LRSS_","_LRI_",0"
+33 SET LRX=$ORDER(^LR(LRDFN,"EPR","AD",LRIENS,1,0))
+34 IF LRX>0
Begin DoDot:1
+35 NEW LRDATA,LRJ,LRREF,LRSRDATA,LRSRTN,LRTITLE
+36 SET LRREF=LRX_","_LRDFN_","
+37 DO GETDATA^LRUEPR(.LRDATA,LRREF)
+38 SET LRSRTN=LRDATA(63.00013,LRREF,1,"I")
+39 IF $PIECE(LRSRTN,";",2)'="SRF("
QUIT
+40 DO SRCASE^LRUEPR(.LRSRDATA,+LRSRTN)
+41 IF $GET(LRSRDATA("ERR"))
Begin DoDot:2
+42 SET LRMD("ERR")=LRSRDATA("ERR")
+43 DO SRCASERR^LRUEPR(LRREF,LRSRTN,LRSRDATA("ERR"))
End DoDot:2
QUIT
+44 FOR LRJ=.14,.164,123,124
Begin DoDot:2
+45 SET LRX=LRSRDATA(130,+LRSRTN_",",LRJ,"I")
+46 IF LRX=""
QUIT
+47 SET LRTITLE=$SELECT(LRJ=.14:"Surgeon",LRJ=.164:"Attending Surgeon",LRJ=123:"Provider",LRJ=124:"Attending Provider",1:"")
+48 IF LRPROVIDER
IF LRX=LRPROVIDER
SET LRDOCS(1)=LRDOCS(1)_"/"_LRTITLE
QUIT
+49 SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=LRX_"^"_$$NAME^XUSER(LRX,"F")_"^"_LRTITLE
End DoDot:2
End DoDot:1
+50 QUIT
+51 ;
+52 ;
RELEASE(LRRELEAS,LRDFN,LRSS,LRI) ;
+1 ; Determine if report has been released
+2 NEW LRFILE,LRFLDS,LRIENS,LRRELAR,LRCT
+3 IF '+$GET(LRDFN)
SET LRRELEAS=0
QUIT
+4 IF $GET(LRSS)=""!("AUSPEMCY"'[LRSS)
SET LRRELEAS=0
QUIT
+5 IF LRSS'="AU"
IF '+$GET(LRI)
SET LRRELEAS=0
QUIT
+6 IF LRSS="AU"
Begin DoDot:1
+7 SET LRFILE=63
SET LRFLDS="14.7;14.8"
SET LRIENS=LRDFN_","
End DoDot:1
+8 IF LRSS'="AU"
Begin DoDot:1
+9 SET LRFILE=$SELECT(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
+10 SET LRFLDS=".11;.13;.15"
+11 SET LRIENS=LRI_","_LRDFN_","
End DoDot:1
+12 if LRFILE=""
QUIT
+13 DO GETS^DIQ(LRFILE,LRIENS,LRFLDS,"I","LRRELAR")
+14 FOR LRCT=1:1:$SELECT(LRSS="AU":2,1:3)
Begin DoDot:1
+15 SET LRRELEAS(LRCT)=+$GET(LRRELAR(LRFILE,LRIENS,$PIECE(LRFLDS,";",LRCT),"I"))
End DoDot:1
+16 QUIT
+17 ;
+18 ;
TIUCHK(LRPTR,LRDFN,LRSS,LRI) ;
+1 ; Check to see if report is in TIU
+2 NEW LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL
+3 IF LRSS=""!("AUSPEMCY"'[LRSS)
SET LRPTR=0
QUIT
+4 IF LRSS="AU"
Begin DoDot:1
+5 SET LRROOT="^LR(LRDFN,101,""A"")"
SET LRIENS=LRDFN_","
+6 SET LRFILE=63.101
End DoDot:1
+7 IF LRSS'="AU"
Begin DoDot:1
+8 SET LRROOT="^LR(LRDFN,LRSS,LRI,.05,""A"")"
+9 SET LRIENS=LRI_","_LRDFN_","
+10 SET LRFILE=$SELECT(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
End DoDot:1
+11 SET LRTREC=$ORDER(@(LRROOT),-1)
+12 IF LRFILE=""!(LRTREC="")
SET LRPTR=0
QUIT
+13 SET LRIENS=LRTREC_","_LRIENS
+14 SET LRPTR=+$$GET1^DIQ(LRFILE,LRIENS,1,"I")
+15 if LRPTR
SET LRPTR("D")=+$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
+16 IF LRSS="AU"
Begin DoDot:1
+17 SET LRFILE=63
SET LRIENS=LRDFN_","
SET LRFLD=14.7
End DoDot:1
+18 IF LRSS'="AU"
Begin DoDot:1
+19 SET LRFLD=$SELECT(LRSS="CY":9,LRSS="SP":8,LRSS="EM":2,1:"")
+20 if LRFLD=""
QUIT
+21 SET LRFILE=+$$GET1^DID(63,LRFLD,"","SPECIFIER")
SET LRFLD=.11
+22 if LRFILE=""
QUIT
+23 SET LRIENS=LRI_","_LRDFN_","
End DoDot:1
+24 SET LRREL=+$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"I")
+25 IF 'LRREL
KILL LRPTR
SET LRPTR=0
QUIT
+26 IF LRREL'=+$GET(LRPTR("D"))
KILL LRPTR
SET LRPTR=0
+27 QUIT
+28 ;
+29 ;
ESIGINF(LRESINF,LRDFN,LRSS,LRI) ;Return Esig Info
+1 NEW LRTIUDA,LRESINF1
+2 if '$DATA(LRDFN)!('$DATA(LRSS))
QUIT
+3 if LRSS=""!("AUSPEMCY"'[LRSS)
QUIT
+4 DO TIUCHK(.LRTIUDA,LRDFN,LRSS,$GET(LRI))
+5 if '+$GET(LRTIUDA)
QUIT
+6 DO EXTRACT^TIULQ(LRTIUDA,"LRESINF1(""ESIG"")",,,,,,1)
+7 if '$DATA(LRESINF1("ESIG",LRTIUDA))
QUIT
+8 SET LRESINF(1)=$GET(LRESINF1("ESIG",LRTIUDA,1501,"E"))
+9 SET LRESINF(2)=$GET(LRESINF1("ESIG",LRTIUDA,1503,"E"))
+10 QUIT
+11 ;
+12 ;
NEWLN(LRTEXT,TAB) ;
+1 SET LCT=$GET(LCT)+1
SET BTAB=0
+2 SET TAB=+TAB
+3 DO GLBWRT(LRTEXT,TAB)
+4 QUIT
+5 ;
+6 ;
GLBWRT(LRTEXT,TAB) ;Write to global
+1 DO GLB(LCT,TAB,BTAB,LRTEXT,GROOT,.ATAB)
+2 SET BTAB=ATAB
+3 QUIT
+4 ;
+5 ;
GLB(LINE,TAB,BTAB,TEXT,ROOT,ATAB) ;
+1 ; This subroutine is used to store report text to a global.
+2 ; Input variables:
+3 ; LINE = Current line number
+4 ; TAB = Desired tab position (not required)
+5 ; BTAB = Current tab position BEFORE text is stored
+6 ; TEXT = Text string to be stored
+7 ; ROOT = Global root
+8 ;
+9 ; Output variables:
+10 ; ATAB = Current tab position after text storage
+11 ;
+12 NEW LRSPC,LRINC,FTEXT,LRLINE
+13 SET LRSPC=""
FOR LRINC=1:1:80
SET LRSPC=LRSPC_" "
+14 if BTAB=""
SET BTAB=0
+15 if +TAB=0
SET TAB=BTAB
+16 SET FTEXT=TEXT
+17 IF TAB
IF TAB>BTAB
SET FTEXT=$EXTRACT(LRSPC,1,TAB-BTAB)_TEXT
+18 if '$DATA(@(ROOT_"0)"))
SET @(ROOT_"0)")="^^^^"_DT_"^"
+19 SET LRLINE=LINE
SET LINE=LINE_",0"
+20 if '$DATA(@(ROOT_LINE_")"))
SET @(ROOT_LINE_")")=""
+21 SET @(ROOT_LINE_")")=@(ROOT_LINE_")")_FTEXT
+22 SET $PIECE(@(ROOT_"0)"),"^",3,4)=LRLINE_"^"_LRLINE
+23 SET ATAB=TAB+$LENGTH(TEXT)
+24 QUIT
+25 ;
+26 ;
PROVIDR ; Entry of provider taken from PRO^LRCAPES
+1 SET LREND=0
+2 Begin DoDot:1
+3 NEW LRPRONM,DIR,DIRUT,DUOUT,X,Y
+4 SET LRPRONM=$$GET1^DIQ(200,+$GET(LRPRO),.01,"I")
+5 IF $LENGTH(LRPRONM)
IF $DATA(^VA(200,"AK.PROVIDER",LRPRONM,+$GET(LRPRO)))#2
IF $$GET^XUA4A72(+$GET(LRPRO),DT)>0
SET DIR("B")=LRPRONM
+6 SET DIR("A")="Provider"
+7 SET LRPRO=0
SET DIR(0)="PO^200:ENMZ"
+8 SET DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U),+Y)),$$GET^XUA4A72(+Y,DT)>0"
+9 DO ^DIR
+10 IF Y>1
SET LRPRO=+Y
End DoDot:1
+11 IF '$GET(LRPRO)
Begin DoDot:1
+12 WRITE !?5,"No Active Provider Selected",!
+13 SET LRNOP=1
+14 SET LRQUIT=1
End DoDot:1
DO END^LRCAPES
QUIT
+15 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
Begin DoDot:1
+16 WRITE !?5,"The accession is corrupt - missing zero node",!
+17 SET LRNOP="7^Corrupt Accession"
+18 SET LRQUIT=1
End DoDot:1
DO END^LRCAPES
+19 QUIT
+20 ;
+21 ;
REFRRL ; Display informational message on referrals
+1 NEW LRMSG
+2 SET LRMSG(1)=$$CJ^XLFSTR("*** NOTE: This "_$PIECE(^DIC(LRDPF,0),"^")_" report will not be stored in TIU",IOM)
SET LRMSG(1,"F")="!!"
+3 SET LRMSG(2)=$$CJ^XLFSTR("and therefore does not have an electronic signature.",IOM)
+4 SET LRMSG(3)=$$CJ^XLFSTR("A hardcopy signature will be required for this report.",IOM)
+5 DO EN^DDIOL(.LRMSG)
+6 QUIT
+7 ;
+8 ;
PG ; Page break
+1 NEW DIR,DIRUT,DUOUT,DTOUT
+2 SET DIR(0)="E"
DO ^DIR
+3 IF $GET(DIRUT)
SET LRQUIT=1
+4 QUIT
+5 ;
+6 ;
END ;
+1 KILL LRYRIN,LRAREA,LRAANM
+2 QUIT
+3 ;
+4 ;
SELBY(X1) ; Select by accession number or unique identifier(UID) or patient name
+1 ; Call with X1= message prompt
+2 ; Returns Y=0 (abort)
+3 ; =1 (accession number)
+4 ; =2 (unique identifier)
+5 ; =3 (patient name)
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 SET DIR(0)="SO^1:Accession number;2:Unique Identifier (UID);3:Patient Name"
SET DIR("A")=X1
+8 SET X=$$GET^XPAR("USR^DIV^PKG","LR AP REPORT SELECTION",1,"Q")
+9 SET DIR("B")=$SELECT(X:X,1:1)
+10 DO ^DIR
+11 IF $DATA(DIRUT)
SET Y=0
+12 QUIT Y
+13 ;
+14 ;
GETPCP(LRPCP,LRDFN,LRSS,LRIDT) ; Return PCP(inpatient PC/attending/outpt PC)
+1 ;
+2 ; Call with LRPCP = primary care provider array (pass by reference)
+3 ; LRDFN = internal entry in file #63
+4 ; LRSS = file #63 subscript
+5 ; LRIDT = file #63 specimen inverse date/time
+6 ;
+7 ; Returns LRPCP = IEN of provider in file #200 (0 if none)
+8 ; LRPCP(1) = standardized formatted name (null if none)
+9 ;
+10 NEW DFN,LRDPF,LRDT,LRX,VADMVT,VAINDT
+11 ;
+12 SET LRPCP=0
SET LRPCP(1)=""
+13 IF +$GET(LRDFN)<0
QUIT
+14 ;
+15 IF LRSS'?1(1"SP",1"CY",1"EM",1"AU")
QUIT
+16 ;
+17 SET LRDPF=$PIECE($GET(^LR(LRDFN,0)),"^",2)
SET DFN=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+18 IF LRDPF'=2
QUIT
+19 ;
+20 ; Retreive specimen collection date/time otherwise default to today
+21 IF LRSS="AU"
SET LRDT=$PIECE($GET(^LR(LRDFN,"AU")),"^")
+22 IF '$TEST
SET LRDT=$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,0)),"^")
+23 IF LRDT<1
SET LRDT=DT
+24 ;
+25 ; Check if patient was inpatient on specimen date/time
+26 ; and retrieve inpatient primary care provider (VAIN(2)) or attending (VAIN(11))
+27 SET VAINDT=LRDT
DO ADM^VADPT2
+28 IF VADMVT
Begin DoDot:1
+29 NEW VAHOW,VAIN,VAROOT
+30 DO INP^VADPT
+31 IF VAIN(2)
SET LRPCP=+VAIN(2)
QUIT
+32 IF VAIN(11)
SET LRPCP=+VAIN(11)
End DoDot:1
+33 ;
+34 ; If no inpatient primary care/attending then check for outpatient PCP
+35 ; 1 - PC Practitioner
+36 ; then 2 - Attending
+37 IF LRPCP<1
Begin DoDot:1
+38 SET LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,1)
+39 IF LRX>0
SET LRPCP=+LRX
QUIT
+40 SET LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,2)
+41 IF LRX>0
SET LRPCP=+LRX
QUIT
End DoDot:1
+42 ;
+43 ; If primary care provider then return formatted name
+44 IF LRPCP
Begin DoDot:1
+45 NEW LRNAME
+46 SET LRNAME("FILE")=200
SET LRNAME("FIELD")=.01
SET LRNAME("IENS")=LRPCP_","
+47 SET LRPCP(1)=$$NAMEFMT^XLFNAME(.LRNAME,"G","DcMP")
End DoDot:1
+48 ;
+49 QUIT
