LRAPUTL ;VA/DALOI/WTY - AP UTILITIES;2/26/01
;;5.2;LAB SERVICE;**1030,1031**;NOV 1, 1997
;
;;VA LR Patche(s): 259,308
;
;Reference to EXTRACT^TIULQ supported by IA #2693
;
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
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) ;
;Lookup by accession number or patient name
K X,Y,LR("CK"),DIR
S LRDATA=-1 W !
S DIR(0)="FO",DIR("A")="Select Accession Number/Pt name"
S DIR("?",1)="Enter the year "_LRYR1_" "_LRAANM_" accession number to"
S DIR("?",1)=DIR("?",1)_" be updated"
S DIR("?")="or locate the accession by entering the patient name."
D ^DIR S LRAN=Y K DIR
I LRAN=""!(LRAN[U) D END S LRDATA=-1 Q
I LRAN'?1N.N D Q
.D PNAME^LRAPDA
.I LRAN<1 S LRDATA=-1 Q
.S LRDATA=LRDFN,LRDATA(1)=$S('LRAU:LRI,1:"")
.D OE1^LR7OB63D
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=0
S X=^LRO(68,LRAAN,1,LRYR2,1,LRAN,0),LRDFN=+X
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)
W !?3,PNM,?35,$G(HRCN),?55,"DOB: ",$$FMTE^XLFDT(DOB,1) ; IHS/MSC/MKK - LR*5.2*1031
S LRI=+$P($G(^LRO(68,LRAAN,1,LRYR2,1,LRAN,3)),"^",5)
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 "
.S MSG(1)=MSG(1)_"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,LRIDT,LRCDT
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")
I LREDT S LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
W !?5,LRCDT
W !?10,LRSPECID,!
I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) W !?15,"PCE ENC # "_^("PCE")
I $L($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 @IOF,!?3,PNM,?35,$G(HRCN),?55,"DOB: ",$$FMTE^XLFDT(DOB,1),! ; IHS/MSC/MKK - LR*5.2*1031
..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),!
S:$G(LRQUIT) LRQUIT=0
Q
;
GETDOCS(LRDOCS,LRDFN,LRSS,LRI,LRSF) ;Return PCP and provider
N LRPF,DFN,LRIENS,LRFLD
S:LRSS="AU" LRSF=63
I '+$G(LRDFN)!($G(LRSS)="")!('+$G(LRSF)) S LRDOCS=0 Q
I "AUSPCYEM"'[LRSS S LRDOCS=0 Q
S LRPF=+$$GET1^DIQ(63,LRDFN_",",.02,"I")
S DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
S LRDOCS(1)=0
I LRPF=2 D
.D INP^VADPT
.S LRDOCS(1)=+VAIN(2)
S LRIENS=LRDFN_","
I LRSS'="AU" S LRIENS=LRI_","_LRIENS,LRFLD=.07
S:LRSS="AU" LRFLD=13.5
S LRDOCS(2)=$$GET1^DIQ(LRSF,LRIENS,LRFLD,"I")
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'=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 D
.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
S LRMSG2=$P(^DIC(LRDPF,0),"^")
S LRMSG="*** NOTE: This "_LRMSG2_" report will not be stored in TIU,"
S LRMSG(1)=$$CJ^XLFSTR(LRMSG,IOM)
S LRMSG(1,"F")="!!"
S LRMSG=" and therefore, does not have an electronic signature."
S LRMSG(2)=$$CJ^XLFSTR(LRMSG,IOM)
S LRMSG="A hardcopy signature will be required for this report."
S LRMSG(3)=$$CJ^XLFSTR(LRMSG,IOM)
D EN^DDIOL(.LRMSG)
K 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
LRAPUTL ;VA/DALOI/WTY - AP UTILITIES;2/26/01
+1 ;;5.2;LAB SERVICE;**1030,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patche(s): 259,308
+4 ;
+5 ;Reference to EXTRACT^TIULQ supported by IA #2693
+6 ;
+7 QUIT
+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
+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 ;
LOOKUP(LRDATA,LRYR1,LRAANM,LRAREA,LRYR2,LRAAN) ;
+1 ;Lookup by accession number or patient name
+2 KILL X,Y,LR("CK"),DIR
+3 SET LRDATA=-1
WRITE !
+4 SET DIR(0)="FO"
SET DIR("A")="Select Accession Number/Pt name"
+5 SET DIR("?",1)="Enter the year "_LRYR1_" "_LRAANM_" accession number to"
+6 SET DIR("?",1)=DIR("?",1)_" be updated"
+7 SET DIR("?")="or locate the accession by entering the patient name."
+8 DO ^DIR
SET LRAN=Y
KILL DIR
+9 IF LRAN=""!(LRAN[U)
DO END
SET LRDATA=-1
QUIT
+10 IF LRAN'?1N.N
Begin DoDot:1
+11 DO PNAME^LRAPDA
+12 IF LRAN<1
SET LRDATA=-1
QUIT
+13 SET LRDATA=LRDFN
SET LRDATA(1)=$SELECT('LRAU:LRI,1:"")
+14 DO OE1^LR7OB63D
End DoDot:1
QUIT
+15 DO OE1^LR7OB63D
+16 WRITE " for "_LRYR1
+17 IF '$DATA(^LRO(68,LRAAN,1,LRYR2,1,LRAN,0))
Begin DoDot:1
+18 SET MSG="Accession # "_LRAN_" for "_LRYR1_" not in "_LRAANM
+19 DO EN^DDIOL(MSG,"","!!")
KILL MSG
+20 SET LRDATA=0
End DoDot:1
QUIT
+21 SET X=^LRO(68,LRAAN,1,LRYR2,1,LRAN,0)
SET LRDFN=+X
+22 IF '$DATA(^LR(LRDFN,0))
QUIT
SET X=^LR(LRDFN,0)
DO ^LRUP
+23 WRITE @IOF
+24 ; W !?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
+25 ; IHS/MSC/MKK - LR*5.2*1031
WRITE !?3,PNM,?35,$GET(HRCN),?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
+26 SET LRI=+$PIECE($GET(^LRO(68,LRAAN,1,LRYR2,1,LRAN,3)),"^",5)
+27 IF LRAREA'="AU"
IF '$DATA(^LR(LRDFN,LRAREA,LRI,0))
Begin DoDot:1
+28 WRITE $CHAR(7)
+29 SET MSG(1)="Inverse date missing or incorrect in Accession Area file "
+30 SET MSG(1)=MSG(1)_"for"
+31 SET MSG(1,"F")="!"
+32 SET MSG(2)=LRAANM_" Year: "_$EXTRACT(LRYR2,2,3)_" Accession: "_LRAN
+33 SET MSG(2,"F")="!"
+34 DO EN^DDIOL(.MSG)
KILL MSG
+35 SET LRDATA=-1
End DoDot:1
QUIT
+36 DO DEMGRPH(LRAN,LRAD,LRAA)
+37 SET LRDATA=LRDFN
SET LRDATA(1)=LRI
+38 QUIT
+39 ;
DEMGRPH(LRAN,LRAD,LRAA) ;Demographics
+1 NEW LRIENS,DA,LRIDT,LRQUIT,LRSPECID,LREDT,LRIDT,LRCDT
+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 IF LREDT
SET LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
+9 WRITE !?5,LRCDT
+10 WRITE !?10,LRSPECID,!
+11 IF $GET(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE"))
WRITE !?15,"PCE ENC # "_^("PCE")
+12 IF $LENGTH($GET(LRSS))
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,.1,0))
Begin DoDot:1
+13 NEW LRX
+14 WRITE !?5,"Tissue Specimen(s): ",!
+15 SET LRX=0
FOR
SET LRX=$ORDER(^LR(LRDFN,LRSS,LRIDT,.1,LRX))
IF LRX<1!(LRQUIT)
QUIT
Begin DoDot:2
+16 IF $Y>(IOSL-10)
DO PG
IF $GET(LRQUIT)
QUIT
Begin DoDot:3
+17 ; W @IOF,!?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1),!
+18 ; IHS/MSC/MKK - LR*5.2*1031
WRITE @IOF,!?3,PNM,?35,$GET(HRCN),?55,"DOB: ",$$FMTE^XLFDT(DOB,1),!
End DoDot:3
+19 WRITE ?15,$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,.1,LRX,0)),U),!
End DoDot:2
End DoDot:1
+20 IF $ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
Begin DoDot:1
+21 WRITE ?5,"Test(s): "
+22 SET LRX=0
+23 FOR
SET LRX=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX))
IF LRX<1!($GET(LRQUIT))
QUIT
Begin DoDot:2
+24 IF $Y>(IOSL-10)
DO PG
IF $GET(LRQUIT)
QUIT
WRITE @IOF
+25 WRITE ?15,$PIECE($GET(^LAB(60,+LRX,0)),U),!
End DoDot:2
End DoDot:1
+26 IF $GET(LRQUIT)
SET LRQUIT=0
+27 QUIT
+28 ;
GETDOCS(LRDOCS,LRDFN,LRSS,LRI,LRSF) ;Return PCP and provider
+1 NEW LRPF,DFN,LRIENS,LRFLD
+2 IF LRSS="AU"
SET LRSF=63
+3 IF '+$GET(LRDFN)!($GET(LRSS)="")!('+$GET(LRSF))
SET LRDOCS=0
QUIT
+4 IF "AUSPCYEM"'[LRSS
SET LRDOCS=0
QUIT
+5 SET LRPF=+$$GET1^DIQ(63,LRDFN_",",.02,"I")
+6 SET DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
+7 SET LRDOCS(1)=0
+8 IF LRPF=2
Begin DoDot:1
+9 DO INP^VADPT
+10 SET LRDOCS(1)=+VAIN(2)
End DoDot:1
+11 SET LRIENS=LRDFN_","
+12 IF LRSS'="AU"
SET LRIENS=LRI_","_LRIENS
SET LRFLD=.07
+13 IF LRSS="AU"
SET LRFLD=13.5
+14 SET LRDOCS(2)=$$GET1^DIQ(LRSF,LRIENS,LRFLD,"I")
+15 QUIT
+16 ;
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 ;
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'=LRPTR("D")
KILL LRPTR
SET LRPTR=0
+27 QUIT
+28 ;
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 ;
NEWLN(LRTEXT,TAB) ;
+1 SET LCT=$GET(LCT)+1
SET BTAB=0
+2 SET TAB=+TAB
+3 DO GLBWRT(LRTEXT,TAB)
+4 QUIT
+5 ;
GLBWRT(LRTEXT,TAB) ;Write to global
+1 DO GLB(LCT,TAB,BTAB,LRTEXT,GROOT,.ATAB)
+2 SET BTAB=ATAB
+3 QUIT
+4 ;
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
Begin DoDot:1
+18 SET FTEXT=$EXTRACT(LRSPC,1,TAB-BTAB)_TEXT
End DoDot:1
+19 IF '$DATA(@(ROOT_"0)"))
SET @(ROOT_"0)")="^^^^"_DT_"^"
+20 SET LRLINE=LINE
SET LINE=LINE_",0"
+21 IF '$DATA(@(ROOT_LINE_")"))
SET @(ROOT_LINE_")")=""
+22 SET @(ROOT_LINE_")")=@(ROOT_LINE_")")_FTEXT
+23 SET $PIECE(@(ROOT_"0)"),"^",3,4)=LRLINE_"^"_LRLINE
+24 SET ATAB=TAB+$LENGTH(TEXT)
+25 QUIT
+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 ;
REFRRL ;Display informational message on referrals
+1 SET LRMSG2=$PIECE(^DIC(LRDPF,0),"^")
+2 SET LRMSG="*** NOTE: This "_LRMSG2_" report will not be stored in TIU,"
+3 SET LRMSG(1)=$$CJ^XLFSTR(LRMSG,IOM)
+4 SET LRMSG(1,"F")="!!"
+5 SET LRMSG=" and therefore, does not have an electronic signature."
+6 SET LRMSG(2)=$$CJ^XLFSTR(LRMSG,IOM)
+7 SET LRMSG="A hardcopy signature will be required for this report."
+8 SET LRMSG(3)=$$CJ^XLFSTR(LRMSG,IOM)
+9 DO EN^DDIOL(.LRMSG)
+10 KILL LRMSG
+11 QUIT
+12 ;
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 ;
END ;
+1 KILL LRYRIN,LRAREA,LRAANM
+2 QUIT
