WVSNOMED ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;2/12/04 14:37
;;1.0;WOMEN'S HEALTH;**16,23,25**;Sep 30, 1998;Build 1
;
; This routine uses the following IAs:
; #1362 - ^ORB3 (controlled)
; #525 - ^LR references (controlled)
; #4298 - ^LR references (private)
; #10035 - ^DPT( references (supported)
; #10070 - ^XMD (supported)
; #10141 - ^XPDUTL (supported)
;
SNOMED() ; Check lab test for SNOMED codes that indicate if pap smear.
; LRDFN,LRI,LRSS must be defined.
; Returns: 0 - lab test is not a pap smear
; 1 - lab test is a pap smear
;
N WVPAP,WVPIEN,WVPIEN1,WVSNOMED,WVTOP
; WVTOP array identifies SNOMED codes (IENS) used for pap smears
S WVTOP(0)=0
S WVPIEN=$$PAPIEN^WVRPCPR()
I 'WVPIEN Q 0 ;pap smear procedure entry not found
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
I WVTOP(0)=0 Q 0 ;no SNOMED codes identified
K WVTOP(0)
S WVPAP=0
I LRSS="CY" S WVPAP=$$CY()
I LRSS="SP" S WVPAP=$$SP()
Q WVPAP
;
CY() ; Check SNOMED codes used by cytology entry
N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED
S (WVFLAG,WVLOOP)=0
; check topography multiple
F S WVLOOP=$O(^LR(LRDFN,"CY",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D
.S WVSNOMED=+$P($G(^LR(LRDFN,"CY",LRI,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,WVLOOP1,WVSNOMED
; check topography multiple
S (WVFLAG,WVLOOP)=0
F S WVLOOP=$O(^LR(LRDFN,"SP",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D
.S WVSNOMED=+$P($G(^LR(LRDFN,"SP",LRI,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 WV7901,WVDR,WVPIEN,WVERR
S WVERR=0
I $D(^WV(790.1,"F",WVLABAN)) D Q
. I $$PATCH^XPDUTL("OR*3.0*210") D Q
..D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.",LRSS_U_WVLABAN_U_LRI)
I '$D(^WV(790,DFN,0)) D ;add patient to File 790, if not there
.D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR)
.Q
Q:WVERR<0 ;quit if new patient could not be added to File 790
S WVPIEN=$$PAPIEN^WVRPCPR()
S WVDR=".02////"_DFN
S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer
S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider
S WVDR=WVDR_";.1////"_$G(DUZ(2)) ;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////"_$G(DUZ(2)) ;accessioning facility
S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession#
S WVDR=WVDR_";2.18////"_LRDFN ;Lab Data file (#63) pointer
S WVDR=WVDR_";2.19////"_LRI ;Lab Data file inverse d/t
S WVDR=WVDR_";2.2////"_LRSS ;Lab Data file subscript (CY/SP)
; add procedure to File 790.1
D NEW2^WVPROC(DFN,WVPIEN,WVDATE,WVDR,"","",.WVERR)
Q:'Y
S WV7901=+Y
I $$PATCH^XPDUTL("OR*3.0*210") D Q
.D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.",LRSS_U_WVLABAN_U_LRI)
.Q
D MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901)
Q
MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) ; Send mail message to case manager
; when pap smear added to FILE 790.1
; Called from above
; DFN -> Patient ien
; WVLABAN -> Lab Accession# (e.g., CY 99 1)
; WVPROV -> File 200 IEN (provider/requestor)
; LRSS -> File 63 subscript (e.g., CY or SP)
; WV7901 -> FILE 790.1 IEN
Q:'$G(DFN)!($G(WVLABAN)="")!($G(LRSS)="")
N WVCMGR,WVLOOP,WVMSG,XMDUZ,XMSUB,XMTEXT,XMY
S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager
S:WVCMGR XMY(WVCMGR)=""
; if no case manager, then get default case manager(s)
I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D
.S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I")
.S:WVCMGR XMY(WVCMGR)=""
.Q
Q:$O(XMY(0))'>0 ;no case manager(s)
S XMDUZ=.5 ;message sender
S XMSUB="Pap Smear report verified for a WH patient"
S WVMSG(1)="A "_$S(LRSS="CY":"Cytology ",LRSS="SP":"Surgical Pathology ",1:"")_"lab test was verified for:"
S WVMSG(2)=" "
S WVMSG(3)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")"
S WVMSG(4)=" WH Accession #: "_$P($G(^WV(790.1,+WV7901,0)),U,1)
S WVMSG(5)=" LAB Accession #: "_WVLABAN
S WVMSG(6)="Test Requestor/Provider: "_$S(+WVPROV:$$GET1^DIQ(200,+WVPROV,.01,"E"),1:"UNKNOWN")
S WVMSG(7)=" "
S WVMSG(8)="Please use CPRS to resolve the Clinical Reminder for this procedure and"
S WVMSG(9)="complete the result."
S XMTEXT="WVMSG("
D ^XMD
Q
;
CPRS(WVORN,WVDFN,WVORDER,WVPROV,WVMSG,WVIEN) ; Generate a CPRS alert
; WVORN - FILE 100.9 IEN
; WVDFN - FILE 2 IEN
; WVORDER - FILE 100 IEN (not currently used)
; WVPROV - FILE 200 IEN
; WVMSG - Free text message
; WVIEN - IEN for a lab or radiology report (not currently used)
;
Q:'$$PATCH^XPDUTL("OR*3.0*210") ;no pap & mam alerts
Q:'WVDFN
Q:'WVORN
I WVPROV]"" S WVARRAY(WVPROV)="" ;provider's IEN
S WVCMGR=$P($G(^WV(790,WVDFN,0)),U,10)
I WVCMGR]"" S WVARRAY(WVCMGR)="" ;women's health case manager's IEN
D EN^ORB3(WVORN,WVDFN,WVORDER,.WVARRAY,WVMSG,WVIEN)
K WVARRAY,WVCMGR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVSNOMED 5376 printed Oct 16, 2024@18:48:32 Page 2
WVSNOMED ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;2/12/04 14:37
+1 ;;1.0;WOMEN'S HEALTH;**16,23,25**;Sep 30, 1998;Build 1
+2 ;
+3 ; This routine uses the following IAs:
+4 ; #1362 - ^ORB3 (controlled)
+5 ; #525 - ^LR references (controlled)
+6 ; #4298 - ^LR references (private)
+7 ; #10035 - ^DPT( references (supported)
+8 ; #10070 - ^XMD (supported)
+9 ; #10141 - ^XPDUTL (supported)
+10 ;
SNOMED() ; Check lab test for SNOMED codes that indicate if pap smear.
+1 ; LRDFN,LRI,LRSS must be defined.
+2 ; Returns: 0 - lab test is not a pap smear
+3 ; 1 - lab test is a pap smear
+4 ;
+5 NEW WVPAP,WVPIEN,WVPIEN1,WVSNOMED,WVTOP
+6 ; WVTOP array identifies SNOMED codes (IENS) used for pap smears
+7 SET WVTOP(0)=0
+8 SET WVPIEN=$$PAPIEN^WVRPCPR()
+9 ;pap smear procedure entry not found
IF 'WVPIEN
QUIT 0
+10 SET WVPIEN1=0
+11 FOR
SET WVPIEN1=$ORDER(^WV(790.2,WVPIEN,2,WVPIEN1))
if 'WVPIEN1
QUIT
Begin DoDot:1
+12 SET WVSNOMED=$PIECE($GET(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1)
+13 if 'WVSNOMED
QUIT
+14 SET WVTOP(0)=WVTOP(0)+1
+15 SET WVTOP(WVSNOMED)=""
+16 QUIT
End DoDot:1
+17 ;no SNOMED codes identified
IF WVTOP(0)=0
QUIT 0
+18 KILL WVTOP(0)
+19 SET WVPAP=0
+20 IF LRSS="CY"
SET WVPAP=$$CY()
+21 IF LRSS="SP"
SET WVPAP=$$SP()
+22 QUIT WVPAP
+23 ;
CY() ; Check SNOMED codes used by cytology entry
+1 NEW WVFLAG,WVLOOP,WVLOOP1,WVSNOMED
+2 SET (WVFLAG,WVLOOP)=0
+3 ; check topography multiple
+4 FOR
SET WVLOOP=$ORDER(^LR(LRDFN,"CY",LRI,2,WVLOOP))
if 'WVLOOP!(WVFLAG=1)
QUIT
Begin DoDot:1
+5 SET WVSNOMED=+$PIECE($GET(^LR(LRDFN,"CY",LRI,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,WVLOOP1,WVSNOMED
+2 ; check topography multiple
+3 SET (WVFLAG,WVLOOP)=0
+4 FOR
SET WVLOOP=$ORDER(^LR(LRDFN,"SP",LRI,2,WVLOOP))
if 'WVLOOP!(WVFLAG=1)
QUIT
Begin DoDot:1
+5 SET WVSNOMED=+$PIECE($GET(^LR(LRDFN,"SP",LRI,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 WV7901,WVDR,WVPIEN,WVERR
+2 SET WVERR=0
+3 IF $DATA(^WV(790.1,"F",WVLABAN))
Begin DoDot:1
+4 IF $$PATCH^XPDUTL("OR*3.0*210")
Begin DoDot:2
+5 DO CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.",LRSS_U_WVLABAN_U_LRI)
End DoDot:2
QUIT
End DoDot:1
QUIT
+6 ;add patient to File 790, if not there
IF '$DATA(^WV(790,DFN,0))
Begin DoDot:1
+7 DO AUTOADD^WVPATE(DFN,DUZ(2),.WVERR)
+8 QUIT
End DoDot:1
+9 ;quit if new patient could not be added to File 790
if WVERR<0
QUIT
+10 SET WVPIEN=$$PAPIEN^WVRPCPR()
+11 SET WVDR=".02////"_DFN
+12 ;File 790.2 pointer
SET WVDR=WVDR_";.04////"_WVPIEN
+13 ;provider
if WVPROV]""
SET WVDR=WVDR_";.07////"_WVPROV
+14 ;health care facility
SET WVDR=WVDR_";.1////"_$GET(DUZ(2))
+15 ;patient location
if WVLOC]""
SET WVDR=WVDR_";.11////"_WVLOC
+16 ;procedure date/time
SET WVDR=WVDR_";.12////"_WVDATE
+17 ;status
SET WVDR=WVDR_";.14////"_"o"
+18 ;entering user and date
SET WVDR=WVDR_";.18////.5;.19////"_DT
+19 ;accessioning facility
SET WVDR=WVDR_";.34////"_$GET(DUZ(2))
+20 ;lab accession#
SET WVDR=WVDR_";2.17////"_WVLABAN
+21 ;Lab Data file (#63) pointer
SET WVDR=WVDR_";2.18////"_LRDFN
+22 ;Lab Data file inverse d/t
SET WVDR=WVDR_";2.19////"_LRI
+23 ;Lab Data file subscript (CY/SP)
SET WVDR=WVDR_";2.2////"_LRSS
+24 ; add procedure to File 790.1
+25 DO NEW2^WVPROC(DFN,WVPIEN,WVDATE,WVDR,"","",.WVERR)
+26 if 'Y
QUIT
+27 SET WV7901=+Y
+28 IF $$PATCH^XPDUTL("OR*3.0*210")
Begin DoDot:1
+29 DO CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.",LRSS_U_WVLABAN_U_LRI)
+30 QUIT
End DoDot:1
QUIT
+31 DO MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901)
+32 QUIT
MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) ; Send mail message to case manager
+1 ; when pap smear added to FILE 790.1
+2 ; Called from above
+3 ; DFN -> Patient ien
+4 ; WVLABAN -> Lab Accession# (e.g., CY 99 1)
+5 ; WVPROV -> File 200 IEN (provider/requestor)
+6 ; LRSS -> File 63 subscript (e.g., CY or SP)
+7 ; WV7901 -> FILE 790.1 IEN
+8 if '$GET(DFN)!($GET(WVLABAN)="")!($GET(LRSS)="")
QUIT
+9 NEW WVCMGR,WVLOOP,WVMSG,XMDUZ,XMSUB,XMTEXT,XMY
+10 ;get case manager
SET WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I")
+11 if WVCMGR
SET XMY(WVCMGR)=""
+12 ; if no case manager, then get default case manager(s)
+13 IF 'WVCMGR
SET WVLOOP=0
FOR
SET WVLOOP=$ORDER(^WV(790.02,WVLOOP))
if 'WVLOOP
QUIT
Begin DoDot:1
+14 SET WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I")
+15 if WVCMGR
SET XMY(WVCMGR)=""
+16 QUIT
End DoDot:1
+17 ;no case manager(s)
if $ORDER(XMY(0))'>0
QUIT
+18 ;message sender
SET XMDUZ=.5
+19 SET XMSUB="Pap Smear report verified for a WH patient"
+20 SET WVMSG(1)="A "_$SELECT(LRSS="CY":"Cytology ",LRSS="SP":"Surgical Pathology ",1:"")_"lab test was verified for:"
+21 SET WVMSG(2)=" "
+22 SET WVMSG(3)=" Patient: "_$PIECE($GET(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")"
+23 SET WVMSG(4)=" WH Accession #: "_$PIECE($GET(^WV(790.1,+WV7901,0)),U,1)
+24 SET WVMSG(5)=" LAB Accession #: "_WVLABAN
+25 SET WVMSG(6)="Test Requestor/Provider: "_$SELECT(+WVPROV:$$GET1^DIQ(200,+WVPROV,.01,"E"),1:"UNKNOWN")
+26 SET WVMSG(7)=" "
+27 SET WVMSG(8)="Please use CPRS to resolve the Clinical Reminder for this procedure and"
+28 SET WVMSG(9)="complete the result."
+29 SET XMTEXT="WVMSG("
+30 DO ^XMD
+31 QUIT
+32 ;
CPRS(WVORN,WVDFN,WVORDER,WVPROV,WVMSG,WVIEN) ; Generate a CPRS alert
+1 ; WVORN - FILE 100.9 IEN
+2 ; WVDFN - FILE 2 IEN
+3 ; WVORDER - FILE 100 IEN (not currently used)
+4 ; WVPROV - FILE 200 IEN
+5 ; WVMSG - Free text message
+6 ; WVIEN - IEN for a lab or radiology report (not currently used)
+7 ;
+8 ;no pap & mam alerts
if '$$PATCH^XPDUTL("OR*3.0*210")
QUIT
+9 if 'WVDFN
QUIT
+10 if 'WVORN
QUIT
+11 ;provider's IEN
IF WVPROV]""
SET WVARRAY(WVPROV)=""
+12 SET WVCMGR=$PIECE($GET(^WV(790,WVDFN,0)),U,10)
+13 ;women's health case manager's IEN
IF WVCMGR]""
SET WVARRAY(WVCMGR)=""
+14 DO EN^ORB3(WVORN,WVDFN,WVORDER,.WVARRAY,WVMSG,WVIEN)
+15 KILL WVARRAY,WVCMGR
+16 QUIT
