| 1 | WVLRLINK ;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 | ;
|
|---|
| 10 | CREATE(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
|
|---|
| 33 | CREATEQ ; 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
|
|---|
| 72 | EXIT ;EP
|
|---|
| 73 | K I,N,X
|
|---|
| 74 | I $D(ZTQUEUED) S ZTREQ="@"
|
|---|
| 75 | Q
|
|---|
| 76 | DELETE(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
|
|---|
| 91 | DELETEQ ; 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
|
|---|
| 131 | HL(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 ""
|
|---|
| 136 | PN(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 | ;
|
|---|
| 143 | MOVE(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
|
|---|
| 153 | MOVEQ ; 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
|
|---|
| 179 | RDC(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 | ;
|
|---|
| 184 | VNVEC() ; 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 | ;
|
|---|
