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

LRAPUTL.m

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