source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVLABCHK.m@ 613

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

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