- 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 Jan 18, 2025@03:48:11 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