- 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 Feb 18, 2025@23:34:29 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