source: FOIAVistA/trunk/r/WOMENS_HEALTH-WV/WVSNOMED.m@ 767

Last change on this file since 767 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1WVSNOMED ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;2/12/04 14:37
2 ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998
3 ;
4 ; This routine uses the following IAs:
5 ; #1362 - ^ORB3 (controlled)
6 ; #525 - ^LR references (controlled)
7 ; #4298 - ^LR references (private)
8 ; #10035 - ^DPT( references (supported)
9 ; #10070 - ^XMD (supported)
10 ; #10141 - ^XPDUTL (supported)
11 ;
12SNOMED() ; Check lab test for SNOMED codes that indicate if pap smear.
13 ; LRDFN,LRI,LRSS must be defined.
14 ; Returns: 0 - lab test is not a pap smear
15 ; 1 - lab test is a pap smear
16 ;
17 N WVPAP,WVPIEN,WVPIEN1,WVSNOMED,WVTOP
18 ; WVTOP array identifies SNOMED codes (IENS) used for pap smears
19 S WVTOP(0)=0
20 S WVPIEN=$$PAPIEN^WVRPCPR()
21 I 'WVPIEN Q 0 ;pap smear procedure entry not found
22 S WVPIEN1=0
23 F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D
24 .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1)
25 .Q:'WVSNOMED
26 .S WVTOP(0)=WVTOP(0)+1
27 .S WVTOP(WVSNOMED)=""
28 .Q
29 I WVTOP(0)=0 Q 0 ;no SNOMED codes identified
30 K WVTOP(0)
31 S WVPAP=0
32 I LRSS="CY" S WVPAP=$$CY()
33 I LRSS="SP" S WVPAP=$$SP()
34 Q WVPAP
35 ;
36CY() ; Check SNOMED codes used by cytology entry
37 N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED
38 S (WVFLAG,WVLOOP)=0
39 ; check topography multiple
40 F S WVLOOP=$O(^LR(LRDFN,"CY",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D
41 .S WVSNOMED=+$P($G(^LR(LRDFN,"CY",LRI,2,WVLOOP,0)),U,1)
42 .Q:'WVSNOMED
43 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1
44 .Q
45 Q WVFLAG
46 ;
47SP() ; Check SNOMED codes used by surgical pathology entry
48 N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED
49 ; check topography multiple
50 S (WVFLAG,WVLOOP)=0
51 F S WVLOOP=$O(^LR(LRDFN,"SP",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D
52 .S WVSNOMED=+$P($G(^LR(LRDFN,"SP",LRI,2,WVLOOP,0)),U,1)
53 .Q:'WVSNOMED
54 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1
55 .Q
56 Q WVFLAG
57 ;
58ADD ; Add pap smear to FILE 790.1
59 N WV7901,WVDR,WVPIEN,WVERR
60 S WVERR=0
61 I '$D(^WV(790,DFN,0)) D ;add patient to File 790, if not there
62 .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR)
63 .Q
64 Q:WVERR<0 ;quit if new patient could not be added to File 790
65 S WVPIEN=$$PAPIEN^WVRPCPR()
66 S WVDR=".02////"_DFN
67 S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer
68 S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider
69 S WVDR=WVDR_";.1////"_$G(DUZ(2)) ;health care facility
70 S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location
71 S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time
72 S WVDR=WVDR_";.14////"_"o" ;status
73 S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date
74 S WVDR=WVDR_";.34////"_$G(DUZ(2)) ;accessioning facility
75 S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession#
76 S WVDR=WVDR_";2.18////"_LRDFN ;Lab Data file (#63) pointer
77 S WVDR=WVDR_";2.19////"_LRI ;Lab Data file inverse d/t
78 S WVDR=WVDR_";2.2////"_LRSS ;Lab Data file subscript (CY/SP)
79 ; add procedure to File 790.1
80 D NEW2^WVPROC(DFN,WVPIEN,WVDATE,WVDR,"","",.WVERR)
81 Q:'Y
82 S WV7901=+Y
83 I $$PATCH^XPDUTL("OR*3.0*210") D Q
84 .D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.","")
85 .Q
86 D MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901)
87 Q
88MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) ; Send mail message to case manager
89 ; when pap smear added to FILE 790.1
90 ; Called from above
91 ; DFN -> Patient ien
92 ; WVLABAN -> Lab Accession# (e.g., CY 99 1)
93 ; WVPROV -> File 200 IEN (provider/requestor)
94 ; LRSS -> File 63 subscript (e.g., CY or SP)
95 ; WV7901 -> FILE 790.1 IEN
96 Q:'$G(DFN)!($G(WVLABAN)="")!($G(LRSS)="")
97 N WVCMGR,WVLOOP,WVMSG,XMDUZ,XMSUB,XMTEXT,XMY
98 S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager
99 S:WVCMGR XMY(WVCMGR)=""
100 ; if no case manager, then get default case manager(s)
101 I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D
102 .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I")
103 .S:WVCMGR XMY(WVCMGR)=""
104 .Q
105 Q:$O(XMY(0))'>0 ;no case manager(s)
106 S XMDUZ=.5 ;message sender
107 S XMSUB="Pap Smear report verified for a WH patient"
108 S WVMSG(1)="A "_$S(LRSS="CY":"Cytology ",LRSS="SP":"Surgical Pathology ",1:"")_"lab test was verified for:"
109 S WVMSG(2)=" "
110 S WVMSG(3)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")"
111 S WVMSG(4)=" WH Accession #: "_$P($G(^WV(790.1,+WV7901,0)),U,1)
112 S WVMSG(5)=" LAB Accession #: "_WVLABAN
113 S WVMSG(6)="Test Requestor/Provider: "_$S(+WVPROV:$$GET1^DIQ(200,+WVPROV,.01,"E"),1:"UNKNOWN")
114 S WVMSG(7)=" "
115 S WVMSG(8)="Please use CPRS to resolve the Clinical Reminder for this procedure and"
116 S WVMSG(9)="complete the result."
117 S XMTEXT="WVMSG("
118 D ^XMD
119 Q
120 ;
121CPRS(WVORN,WVDFN,WVORDER,WVPROV,WVMSG,WVIEN) ; Generate a CPRS alert
122 ; WVORN - FILE 100.9 IEN
123 ; WVDFN - FILE 2 IEN
124 ; WVORDER - FILE 100 IEN (not currently used)
125 ; WVPROV - FILE 200 IEN
126 ; WVMSG - Free text message
127 ; WVIEN - IEN for a lab or radiology report (not currently used)
128 ;
129 Q:'$$PATCH^XPDUTL("OR*3.0*210") ;no pap & mam alerts
130 Q:'WVDFN
131 Q:'WVORN
132 I WVPROV]"" S WVARRAY(WVPROV)="" ;provider's IEN
133 S WVCMGR=$P($G(^WV(790,WVDFN,0)),U,10)
134 I WVCMGR]"" S WVARRAY(WVCMGR)="" ;women's health case manager's IEN
135 D EN^ORB3(WVORN,WVDFN,WVORDER,.WVARRAY,WVMSG,WVIEN)
136 K WVARRAY,WVCMGR
137 Q
Note: See TracBrowser for help on using the repository browser.