source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVLRLINK.m@ 623

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

initial load of WorldVistAEHR
File size: 7.8 KB
RevLine 
[613]1WVLRLINK ;HIOFO/FT-LAB-WOMEN'S HEALTH LINK ;9/29/04 14:34
2 ;;1.0;WOMEN'S HEALTH;**6,10,16**;Sep 30, 1998
3 ;
4 ; This routine uses the following IAs:
5 ; #10035 - ^DPT references (supported)
6 ; #10063 - ^%ZTLOAD (supported)
7 ; #10070 - ^XMD (supported)
8 ; #10103 - ^XLFDT (supported)
9 ;
10CREATE(DFN,LRDFN,LRI,LRA,LRSS) ;
11 ; Add lab test to WH file (#790.08).
12 ; Called by REPORT RELEASE DATE/TIME field in:
13 ; a) File 63, Field 63.08,.11
14 ; b) File 63, Field 63.09,.11
15 ; Input: DFN = PATIENT DFN
16 ; LRDFN = FILE 63 IEN (+^DPT(DFN,"LR"))
17 ; LRI = INVERSE DATE/TIME OF TEST
18 ; LRA = ZERO NODE OF THE CY or SP ENTRY
19 ; LRSS = File 63 subscript (e.g., CY or SP)
20 ;
21 Q:($G(DFN)']"")!($G(LRDFN)']"")!($G(LRI)']"")!($G(LRA)']"")!($G(LRSS)']"")
22 Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry
23 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null
24 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
25 S ZTRTN="CREATEQ^WVLRLINK",ZTDESC="WV CREATE FILE 790.08 ENTRY"
26 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")=""
27 S ZTSAVE("LRSS")="",ZTIO=""
28 S ZTDTH=$$HADD^XLFDT($H,"","","",120) ;time delay if MOVE entry point
29 ; is called to delete a bogus entry first so check of lab accession
30 ; x-ref doesn't fail.
31 D ^%ZTLOAD
32 Q
33CREATEQ ; Called from CREATE above
34 ; WVLOC = WARD/CLINIC/LOCATION (FILE #44)
35 ; WVDATE = DATE OF THE PROCEDURE (FM date/time)
36 ; WVDR = DR STRING
37 ; WVPROV = ORDERING PROVIDER (FILE #200)
38 ; WVLABAN = LAB ACCESSION # (e.g., CY 99 1)
39 N WVDATE,WVDR,WVLABAN,WVLABAN0,WVLOC,WVPROV
40 Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female
41 Q:'$$VNVEC() ;vet/non-vet/eligibility code check
42 S WVDATE=$P(LRA,U,1) ;date/time specimen taken
43 S WVLABAN=$P(LRA,U,6) ;lab accession#
44 S WVLOC=$P(LRA,U,8) ;patient location
45 I WVLOC]"" S WVLOC=$$HL(WVLOC) ;convert location to File 44 pointer
46 S WVPROV=$P(LRA,U,7) ;requesting provider
47 ; Quit if this lab test has already been sent to FILE 790.1.
48 Q:$D(^WV(790.1,"F",WVLABAN))
49 I LRSS'="CY",LRSS'="SP" Q ;not cytology or surgical pathology
50 ; ===============================================================
51 ; Check SNOMED codes and determine if lab test is a pap smear and
52 ; can be automatically created in FILE 790.1.
53 I $$SNOMED^WVSNOMED() D Q
54 .D ADD^WVSNOMED
55 .Q
56 ; ===============================================================
57 S WVDR=".02////"_DFN
58 S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV
59 S WVDR=WVDR_";.1////"_$G(DUZ(2))
60 S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC
61 S WVDR=WVDR_";.12////"_WVDATE
62 S WVDR=WVDR_";.18////.5;.19////"_DT_";.34////"_$G(DUZ(2))
63 S WVDR=WVDR_";2.18////"_LRDFN_";2.19////"_LRI_";2.2////"_LRSS
64 S X=WVLABAN,Y=0
65 K DD,DO
66 N DIC,DLAYGO
67 S DIC("DR")=WVDR,DIC="^WV(790.08,",DIC(0)="ML",DLAYGO=790.08
68 D FILE^DICN
69 Q:Y<1 ;FILE 790.08 entry was not created
70 D MAIL^WVLABWP(DFN,WVLABAN,WVPROV,LRSS) ;patient, lab accession #, provider/requestor, lab subscript (CY or SP)
71 Q
72EXIT ;EP
73 K I,N,X
74 I $D(ZTQUEUED) S ZTREQ="@"
75 Q
76DELETE(DFN,LRDFN,LRI,LRA,LRSS) ;
77 ; Modify WH to reflect change in lab report status (no longer released).
78 ; Called by REPORT RELEASE DATE/TIME field xref in:
79 ; a) File 63, Field 63.08,.11
80 ; b) File 63, Field 63.09,.11
81 Q:'$D(DFN)!('$D(LRDFN))!('$D(LRI))!('$D(LRA))!('$D(LRSS))
82 Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry
83 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null
84 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
85 S ZTRTN="DELETEQ^WVLRLINK",ZTDESC="WV Change in Lab Rpt Status"
86 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")=""
87 S ZTSAVE("LRSS")=""
88 S ZTIO="",ZTDTH=$H
89 D ^%ZTLOAD
90 Q
91DELETEQ ; Called from DELETE above.
92 N WVIEN,WVDATE,WVCMGR,WVLABAN,WVLOOP,WVMSG,WVNODE,WVPN ;,WVPROV
93 N XMDUZ,XMSUB,XMTEXT,XMY ;send mail message to case manager
94 S WVLABAN=$P(LRA,U,6) ;lab accession#
95 Q:WVLABAN=""
96 S WVIEN=$O(^WV(790.08,"B",WVLABAN,0))
97 I WVIEN D DELETE^WVLABADD(WVIEN) Q ;delete, not yet addressed
98 Q:'$D(^WV(790.1,"F",WVLABAN)) ;never entered in WH procedure file
99 ; Next look up lab test in WH procedure file and send warning message
100 ; to WH case manager.
101 S WVIEN=$O(^WV(790.1,"F",WVLABAN,0))
102 Q:'$D(^WV(790.1,WVIEN,0))
103 D RADMOD^WVPROC(WVIEN) ;update procedure status to "open"
104 S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager
105 S:WVCMGR XMY(WVCMGR)=""
106 ; if no case manager, then get default case manager(s)
107 I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D
108 .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I")
109 .S:WVCMGR XMY(WVCMGR)=""
110 .Q
111 Q:$O(XMY(0))'>0 ;no case manager(s)
112 ;S:WVPROV XMY(WVPROV)=""
113 S WVNODE=$G(^WV(790.1,+WVIEN,0))
114 S WVPN=$E($P(WVNODE,U,1),1,2),WVPN=$$PN(WVPN)
115 S XMDUZ=.5 ;message sender
116 S XMSUB="Lab Report for WH patient is UNVERIFIED"
117 S WVMSG(1)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")"
118 S WVMSG(2)=" WH Accession #: "_$P(WVNODE,U,1)_" Procedure Type: "_$S(WVPN]"":WVPN,1:"Unknown")
119 S WVMSG(3)="Lab Accession #: "_WVLABAN
120 S WVMSG(4)=" "
121 S WVMSG(5)="NOTE: This lab test has been UNVERIFIED in the LAB package."
122 S WVMSG(6)=" "
123 S WVMSG(7)="The status of the associated WH procedure has been changed to 'open',"
124 S WVMSG(8)="You may wish to contact Lab Service to find out the reason for the change."
125 S WVMSG(9)="Please use the 'Edit a Procedure' option in the WOMEN'S HEALTH package"
126 S WVMSG(10)="to modify/close this procedure."
127 S XMTEXT="WVMSG("
128 D ^XMD
129 I $D(ZTQUEUED) S ZTREQ="@"
130 Q
131HL(WVLOC) ; Get Hospital Location file (#44) pointer
132 N WVARRAY,WVERR
133 D FIND^DIC(44,"","","X",WVLOC,"","C","","","WVARRAY","WVERR")
134 I +$G(WVARRAY("DILIST",0))=1 Q +WVARRAY("DILIST",2,1)
135 Q ""
136PN(X) ; Get procedure name
137 I X="" Q ""
138 S X=$O(^WV(790.2,"D",X,0)) ;look at abbreviation x-ref
139 I 'X Q ""
140 S X=$P($G(^WV(790.2,+X,0)),U,1)
141 Q X
142 ;
143MOVE(DFN,LRDFN,LRI,LRA,LRSS) ; Called from Lab package when a lab accession is
144 ; moved from one patient to another because the test was originally
145 ; associated to the wrong patient.
146 Q:'$D(DFN)!('$D(LRDFN))!('$D(LRI))!('$D(LRA))!('$D(LRSS))
147 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
148 S ZTRTN="MOVEQ^WVLRLINK",ZTDESC="WV Lab Accession moved to another patient"
149 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")=""
150 S ZTSAVE("LRSS")="",ZTIO="",ZTDTH=$H
151 D ^%ZTLOAD
152 Q
153MOVEQ ; Called from MOVE above
154 N DA,DIE,DR
155 N WVACCN,WVCMGR,WVDFN,WVIEN,WVLABAN,WVLOOP,WVNIEN,WVNODE,WVPIEN,WVPN,WVRD
156 S WVLABAN=$P(LRA,U,6) ;lab accession#
157 Q:WVLABAN=""
158 S WVIEN=$O(^WV(790.08,"B",WVLABAN,0)) ;check WV LAB TESTS first
159 I WVIEN D Q ;fix/delete File 790.8 entry, not a file (790.1) entry
160 .D DELETE^WVLABADD(WVIEN)
161 .Q
162 ;
163 S WVPIEN=$O(^WV(790.1,"F",WVLABAN,0)) ;check WH Procedure file
164 Q:'WVPIEN ;lab test was not converted into a WH procedure
165 S WVNODE=$G(^WV(790.1,WVPIEN,0))
166 S WVACCN=$P(WVNODE,U,1) ;WH accession#
167 S WVDFN=+$P(WVNODE,U,2) ;DFN for existing patient
168 Q:WVACCN=""
169 S WVRD=$$RDC("Error/disregard")
170 ; delete links to lab test entry so wrong lab report doesn't display
171 S DIE="^WV(790.1,",DA=WVPIEN,DR=".05////"_WVRD_";2.17///@;2.18///@;2.19///@;2.2///@"
172 ; include amended comment?
173 D ^DIE
174 S WVNIEN=$O(^WV(790.4,"C",WVACCN,0)) ;notification for that procedure?
175 ; Send a mail message to case manager about patient change
176 D MOVE^WVLABWP(WVDFN,WVNODE,WVNIEN)
177 I $D(ZTQUEUED) S ZTREQ="@"
178 Q
179RDC(WVRD) ; Return ien of Result/Diagnosis code
180 ; input text of result/diagnois
181 I WVRD="" Q ""
182 Q +$O(^WV(790.31,"B",WVRD,0))
183 ;
184VNVEC() ; Veteran/Non-Veteran/Eligibility Code check
185 ; DFN must be defined
186 ; Returns 1 - veteran
187 ; include all non-vets flag set to YES
188 ; non-vet patient's eligibility code is on list to track
189 N WVALL,WVLOOP,X,Y
190 I $E($$VET^WVUTL1A(DFN))="Y" Q 1 ;veteran
191 S WVALL=$P($G(^WV(790.02,DUZ(2),0)),U,26) ;include all non-vets
192 I WVALL=1!(WVALL="") Q 1 ;1=YES
193 S WVLOOP=+$$ELIG^WVUTL9(DFN) ;internal^external elig code
194 I 'WVLOOP Q 0 ;no eligibility code
195 I $D(^WV(790.02,DUZ(2),6,WVLOOP)) Q 1 ;code is on list to be tracked
196 Q 0
197 ;
Note: See TracBrowser for help on using the repository browser.