source: FOIAVistA/trunk/r/WOMENS_HEALTH-WV/WVLABCHK.m@ 635

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

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1WVLABCHK ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;10/25/04 10:23
2 ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998
3 ;
4 ; This routine uses the following IAs:
5 ; #525 - ^LR references (controlled)
6 ; #4298 - ^LR references (private)
7 ; #10103 - ^XLFDT calls (supported)
8 ; #10063 - ^%ZTLOAD (supported)
9 ; #10141 - ^XPDUTL (supported)
10 ;
11 ; This routine supports the following IAs:
12 ; CREATE - 4525
13 ;
14CREATE(DFN,LRDFN,LRI,LRA,LRSS) ;
15 ; Add lab test to WH file (#790.08).
16 ; Called by REPORT RELEASE DATE/TIME field in:
17 ; a) File 63, Field 63.08,.11
18 ; b) File 63, Field 63.09,.11
19 ; Input: DFN = PATIENT DFN
20 ; LRDFN = FILE 63 IEN (+^DPT(DFN,"LR"))
21 ; LRI = INVERSE DATE/TIME OF TEST
22 ; LRA = ZERO NODE OF THE CY or SP ENTRY
23 ; LRSS = File 63 subscript (e.g., CY or SP)
24 ;
25 Q:($G(DFN)']"")!($G(LRDFN)']"")!($G(LRI)']"")!($G(LRA)']"")!($G(LRSS)']"")
26 Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry
27 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null
28 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
29 S ZTRTN="CREATEQ^WVLABCHK",ZTDESC="WV CHECK SNOMED CODE CHANGES"
30 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")=""
31 S ZTSAVE("LRSS")="",ZTIO=""
32 S ZTDTH=$$HADD^XLFDT($H,"","","",150) ;don't want the SNOMED trigger to
33 ; conflict with the report verification trigger
34 D ^%ZTLOAD
35 Q
36CREATEQ ; Called from CREATE above
37 I $D(ZTQUEUED) S ZTREQ="@"
38 N WVDATE,WVDFN,WVDUZ2,WVIEN,WVLABAN,WVLOC,WVLRDFN,WVLRI,WVLRSS,WVNODE,WVPAP,WVPIEN,WVPROV,WVTOP,X,Y
39 Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female
40 S WVLABAN=$P(LRA,U,6) ;lab accession#
41 Q:$D(^WV(790.1,"F",WVLABAN)) ;already tracked
42 ; check WH site parameters
43 Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry
44 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null
45 Q:'$$VNVEC^WVLRLINK() ;vet/non-vet/eligibility code check
46 D CODES ;what SNOMED codes are we looking for?
47 I WVTOP(0)=0 Q ;no SNOMED codes identified
48 S WVPIEN=$$PAPIEN^WVRPCPR()
49 Q:'WVPIEN
50 S WVIEN=$O(^WV(790.08,"B",WVLABAN,0))
51 Q:'WVIEN
52 S WVNODE=$G(^WV(790.08,WVIEN,0))
53 Q:WVNODE=""
54 S WVLRDFN=$P(WVNODE,U,36)
55 Q:'WVLRDFN
56 S WVLRI=$P(WVNODE,U,37)
57 Q:'WVLRI
58 S WVLRSS=$P(WVNODE,U,38)
59 S WVDFN=$P(WVNODE,U,2)
60 S WVPROV=$P(WVNODE,U,7)
61 S WVLOC=$P(WVNODE,U,11)
62 S WVDATE=$P(WVNODE,U,12)
63 S WVLABAN=$P(WVNODE,U,1)
64 S WVDUZ2=$P(WVNODE,U,10)
65 I WVLRSS="CY" D Q
66 .S WVPAP=$$CY()
67 .D:WVPAP ADD
68 .Q
69 I WVLRSS="SP" D Q
70 .S WVPAP=$$SP()
71 .D:WVPAP ADD
72 .Q
73 Q
74 ;
75CODES ; WVTOP array identifies SNOMED codes (IENS) used for pap smears
76 N WVPIEN,WVPIEN1,WVSNOMED
77 S WVTOP(0)=0
78 S WVPIEN=$$PAPIEN^WVRPCPR()
79 I 'WVPIEN Q ;pap smear procedure not identified
80 S WVPIEN1=0
81 F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D
82 .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1)
83 .Q:'WVSNOMED
84 .S WVTOP(0)=WVTOP(0)+1
85 .S WVTOP(WVSNOMED)=""
86 .Q
87 Q
88CY() ; Check SNOMED codes used by cytology entry
89 N WVFLAG,WVLOOP,WVSNOMED
90 S (WVFLAG,WVLOOP)=0
91 ; check topography multiple
92 F S WVLOOP=$O(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D
93 .S WVSNOMED=+$P($G(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP,0)),U,1)
94 .Q:'WVSNOMED
95 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1
96 .Q
97 Q WVFLAG
98 ;
99SP() ; Check SNOMED codes used by surgical pathology entry
100 N WVFLAG,WVLOOP,WVSNOMED
101 ; check topography multiple
102 S (WVFLAG,WVLOOP)=0
103 F S WVLOOP=$O(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D
104 .S WVSNOMED=+$P($G(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP,0)),U,1)
105 .Q:'WVSNOMED
106 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1
107 .Q
108 Q WVFLAG
109 ;
110ADD ; Add pap smear to FILE 790.1
111 N WVDR,WVERR
112 S WVERR=0
113 I '$D(^WV(790,WVDFN,0)) D ;add patient to File 790, if not there
114 .D AUTOADD^WVPATE(WVDFN,WVDUZ2,.WVERR)
115 .Q
116 Q:WVERR<0 ;quit if new patient could not be added to File 790
117 S WVDR=".02////"_WVDFN
118 S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer
119 S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider
120 S WVDR=WVDR_";.1////"_WVDUZ2 ;health care facility
121 S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location
122 S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time
123 S WVDR=WVDR_";.14////"_"o" ;status
124 S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date
125 S WVDR=WVDR_";.34////"_WVDUZ2 ;accessioning facility
126 S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession#
127 S WVDR=WVDR_";2.18////"_WVLRDFN ;Lab Data file (#63) pointer
128 S WVDR=WVDR_";2.19////"_WVLRI ;Lab Data file inverse d/t
129 S WVDR=WVDR_";2.2////"_WVLRSS ;Lab Data file subscript (CY/SP)
130 ; add procedure to File 790.1
131 D NEW2^WVPROC(WVDFN,WVPIEN,WVDATE,WVDR,"","",.WVERR)
132 Q:'Y
133 I $$PATCH^XPDUTL("OR*3.0*210") D
134 .D CPRS^WVSNOMED(70,WVDFN,"",WVPROV,"Pap Smear results available.","")
135 .D DELETE^WVLABADD(WVIEN)
136 .Q
137 Q
Note: See TracBrowser for help on using the repository browser.