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 ;VA/DALOI/WTY - AP UTILITIES;2/26/01
  1.  ;;5.2;LAB SERVICE;**1030,1031**;NOV 1, 1997
  1.  ;
  1.  ;;VA LR Patche(s): 259,308
  1.  ;
  1.  ;Reference  to EXTRACT^TIULQ supported by IA #2693
  1.  ;
  1.  Q
  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
  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. LOOKUP(LRDATA,LRYR1,LRAANM,LRAREA,LRYR2,LRAAN) ;
  1.  ;Lookup by accession number or patient name
  1.  K X,Y,LR("CK"),DIR
  1.  S LRDATA=-1 W !
  1.  S DIR(0)="FO",DIR("A")="Select Accession Number/Pt name"
  1.  S DIR("?",1)="Enter the year "_LRYR1_" "_LRAANM_" accession number to"
  1.  S DIR("?",1)=DIR("?",1)_" be updated"
  1.  S DIR("?")="or locate the accession by entering the patient name."
  1.  D ^DIR S LRAN=Y K DIR
  1.  I LRAN=""!(LRAN[U) D END S LRDATA=-1 Q
  1.  I LRAN'?1N.N D  Q
  1.  .D PNAME^LRAPDA
  1.  .I LRAN<1 S LRDATA=-1 Q
  1.  .S LRDATA=LRDFN,LRDATA(1)=$S('LRAU:LRI,1:"")
  1.  .D OE1^LR7OB63D
  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=0
  1.  S X=^LRO(68,LRAAN,1,LRYR2,1,LRAN,0),LRDFN=+X
  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.  W !?3,PNM,?35,$G(HRCN),?55,"DOB: ",$$FMTE^XLFDT(DOB,1)    ; IHS/MSC/MKK - LR*5.2*1031
  1.  S LRI=+$P($G(^LRO(68,LRAAN,1,LRYR2,1,LRAN,3)),"^",5)
  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 "
  1.  .S MSG(1)=MSG(1)_"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. DEMGRPH(LRAN,LRAD,LRAA) ;Demographics
  1.  N LRIENS,DA,LRIDT,LRQUIT,LRSPECID,LREDT,LRIDT,LRCDT
  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.  I LREDT S LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
  1.  W !?5,LRCDT
  1.  W !?10,LRSPECID,!
  1.  I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) W !?15,"PCE ENC # "_^("PCE")
  1.  I $L($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 @IOF,!?3,PNM,?35,$G(HRCN),?55,"DOB: ",$$FMTE^XLFDT(DOB,1),!   ; IHS/MSC/MKK - LR*5.2*1031
  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),!
  1.  S:$G(LRQUIT) LRQUIT=0
  1.  Q
  1.  ;
  1. GETDOCS(LRDOCS,LRDFN,LRSS,LRI,LRSF) ;Return PCP and provider
  1.  N LRPF,DFN,LRIENS,LRFLD
  1.  S:LRSS="AU" LRSF=63
  1.  I '+$G(LRDFN)!($G(LRSS)="")!('+$G(LRSF)) S LRDOCS=0 Q
  1.  I "AUSPCYEM"'[LRSS S LRDOCS=0 Q
  1.  S LRPF=+$$GET1^DIQ(63,LRDFN_",",.02,"I")
  1.  S DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
  1.  S LRDOCS(1)=0
  1.  I LRPF=2 D
  1.  .D INP^VADPT
  1.  .S LRDOCS(1)=+VAIN(2)
  1.  S LRIENS=LRDFN_","
  1.  I LRSS'="AU" S LRIENS=LRI_","_LRIENS,LRFLD=.07
  1.  S:LRSS="AU" LRFLD=13.5
  1.  S LRDOCS(2)=$$GET1^DIQ(LRSF,LRIENS,LRFLD,"I")
  1.  Q
  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. 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'=LRPTR("D") K LRPTR S LRPTR=0
  1.  Q
  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. NEWLN(LRTEXT,TAB) ;
  1.  S LCT=$G(LCT)+1,BTAB=0
  1.  S TAB=+TAB
  1.  D GLBWRT(LRTEXT,TAB)
  1.  Q
  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. 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 D
  1.  .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. 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. REFRRL ;Display informational message on referrals
  1.  S LRMSG2=$P(^DIC(LRDPF,0),"^")
  1.  S LRMSG="*** NOTE: This "_LRMSG2_" report will not be stored in TIU,"
  1.  S LRMSG(1)=$$CJ^XLFSTR(LRMSG,IOM)
  1.  S LRMSG(1,"F")="!!"
  1.  S LRMSG="  and therefore, does not have an electronic signature."
  1.  S LRMSG(2)=$$CJ^XLFSTR(LRMSG,IOM)
  1.  S LRMSG="A hardcopy signature will be required for this report."
  1.  S LRMSG(3)=$$CJ^XLFSTR(LRMSG,IOM)
  1.  D EN^DDIOL(.LRMSG)
  1.  K LRMSG
  1.  Q
  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. END ;
  1.  K LRYRIN,LRAREA,LRAANM
  1.  Q