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

WVLABCHK.m

Go to the documentation of this file.
  1. WVLABCHK ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;10/25/04 10:23
  1. ;;1.0;WOMEN'S HEALTH;**16,23**;Sep 30, 1998;Build 5
  1. ;
  1. ; This routine uses the following IAs:
  1. ; #525 - ^LR references (controlled)
  1. ; #4298 - ^LR references (private)
  1. ; #10103 - ^XLFDT calls (supported)
  1. ; #10063 - ^%ZTLOAD (supported)
  1. ; #10141 - ^XPDUTL (supported)
  1. ; #10035 - ^DPT (supported)
  1. ;
  1. ; This routine supports the following IAs:
  1. ; CREATE - 4525
  1. ;
  1. CREATE(DFN,LRDFN,LRI,LRA,LRSS) ;
  1. ; Add lab test to WH file (#790.08).
  1. ; Called by REPORT RELEASE DATE/TIME field in:
  1. ; a) File 63, Field 63.08,.11
  1. ; b) File 63, Field 63.09,.11
  1. ; Input: DFN = PATIENT DFN
  1. ; LRDFN = FILE 63 IEN (+^DPT(DFN,"LR"))
  1. ; LRI = INVERSE DATE/TIME OF TEST
  1. ; LRA = ZERO NODE OF THE CY or SP ENTRY
  1. ; LRSS = File 63 subscript (e.g., CY or SP)
  1. ;
  1. Q:($G(DFN)']"")!($G(LRDFN)']"")!($G(LRI)']"")!($G(LRA)']"")!($G(LRSS)']"")
  1. Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry
  1. Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null
  1. N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1. S ZTRTN="CREATEQ^WVLABCHK",ZTDESC="WV CHECK SNOMED CODE CHANGES"
  1. S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")=""
  1. S ZTSAVE("LRSS")="",ZTIO=""
  1. S ZTDTH=$$HADD^XLFDT($H,"","","",150) ;don't want the SNOMED trigger to
  1. ; conflict with the report verification trigger
  1. D ^%ZTLOAD
  1. Q
  1. CREATEQ ; Called from CREATE above
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. N WVDATE,WVDFN,WVDUZ2,WVIEN,WVLABAN,WVLOC,WVLRDFN,WVLRI,WVLRSS,WVNODE,WVPAP,WVPIEN,WVPROV,WVTOP,X,Y
  1. Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female
  1. S WVLABAN=$P(LRA,U,6) ;lab accession#
  1. Q:$D(^WV(790.1,"F",WVLABAN)) ;already tracked
  1. ; check WH site parameters
  1. Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry
  1. Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null
  1. Q:'$$VNVEC^WVLRLINK() ;vet/non-vet/eligibility code check
  1. D CODES ;what SNOMED codes are we looking for?
  1. I WVTOP(0)=0 Q ;no SNOMED codes identified
  1. S WVPIEN=$$PAPIEN^WVRPCPR()
  1. Q:'WVPIEN
  1. S WVIEN=$O(^WV(790.08,"B",WVLABAN,0))
  1. Q:'WVIEN
  1. S WVNODE=$G(^WV(790.08,WVIEN,0))
  1. Q:WVNODE=""
  1. S WVLRDFN=$P(WVNODE,U,36)
  1. Q:'WVLRDFN
  1. S WVLRI=$P(WVNODE,U,37)
  1. Q:'WVLRI
  1. S WVLRSS=$P(WVNODE,U,38)
  1. S WVDFN=$P(WVNODE,U,2)
  1. S WVPROV=$P(WVNODE,U,7)
  1. S WVLOC=$P(WVNODE,U,11)
  1. S WVDATE=$P(WVNODE,U,12)
  1. S WVLABAN=$P(WVNODE,U,1)
  1. S WVDUZ2=$P(WVNODE,U,10)
  1. I WVLRSS="CY" D Q
  1. .S WVPAP=$$CY()
  1. .D:WVPAP ADD
  1. .Q
  1. I WVLRSS="SP" D Q
  1. .S WVPAP=$$SP()
  1. .D:WVPAP ADD
  1. .Q
  1. Q
  1. ;
  1. CODES ; WVTOP array identifies SNOMED codes (IENS) used for pap smears
  1. N WVPIEN,WVPIEN1,WVSNOMED
  1. S WVTOP(0)=0
  1. S WVPIEN=$$PAPIEN^WVRPCPR()
  1. I 'WVPIEN Q ;pap smear procedure not identified
  1. S WVPIEN1=0
  1. F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D
  1. .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1)
  1. .Q:'WVSNOMED
  1. .S WVTOP(0)=WVTOP(0)+1
  1. .S WVTOP(WVSNOMED)=""
  1. .Q
  1. Q
  1. CY() ; Check SNOMED codes used by cytology entry
  1. N WVFLAG,WVLOOP,WVSNOMED
  1. S (WVFLAG,WVLOOP)=0
  1. ; check topography multiple
  1. F S WVLOOP=$O(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D
  1. .S WVSNOMED=+$P($G(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP,0)),U,1)
  1. .Q:'WVSNOMED
  1. .I $D(WVTOP(WVSNOMED)) S WVFLAG=1
  1. .Q
  1. Q WVFLAG
  1. ;
  1. SP() ; Check SNOMED codes used by surgical pathology entry
  1. N WVFLAG,WVLOOP,WVSNOMED
  1. ; check topography multiple
  1. S (WVFLAG,WVLOOP)=0
  1. F S WVLOOP=$O(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D
  1. .S WVSNOMED=+$P($G(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP,0)),U,1)
  1. .Q:'WVSNOMED
  1. .I $D(WVTOP(WVSNOMED)) S WVFLAG=1
  1. .Q
  1. Q WVFLAG
  1. ;
  1. ADD ; Add pap smear to FILE 790.1
  1. N WVDR,WVERR
  1. S WVERR=0
  1. I '$D(^WV(790,WVDFN,0)) D ;add patient to File 790, if not there
  1. .D AUTOADD^WVPATE(WVDFN,WVDUZ2,.WVERR)
  1. .Q
  1. Q:WVERR<0 ;quit if new patient could not be added to File 790
  1. S WVDR=".02////"_WVDFN
  1. S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer
  1. S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider
  1. S WVDR=WVDR_";.1////"_WVDUZ2 ;health care facility
  1. S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location
  1. S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time
  1. S WVDR=WVDR_";.14////"_"o" ;status
  1. S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date
  1. S WVDR=WVDR_";.34////"_WVDUZ2 ;accessioning facility
  1. S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession#
  1. S WVDR=WVDR_";2.18////"_WVLRDFN ;Lab Data file (#63) pointer
  1. S WVDR=WVDR_";2.19////"_WVLRI ;Lab Data file inverse d/t
  1. S WVDR=WVDR_";2.2////"_WVLRSS ;Lab Data file subscript (CY/SP)
  1. ; add procedure to File 790.1
  1. D NEW2^WVPROC(WVDFN,WVPIEN,WVDATE,WVDR,"","",.WVERR)
  1. Q:'Y
  1. I $$PATCH^XPDUTL("OR*3.0*210") D
  1. .D CPRS^WVSNOMED(70,WVDFN,"",WVPROV,"Pap Smear results available.",WVLRSS_U_WVLABAN_U_WVLRI)
  1. .D DELETE^WVLABADD(WVIEN)
  1. .Q
  1. Q