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