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

WVLRLINK ;HIOFO/FT-LAB-WOMEN'S HEALTH LINK  ;9/29/04  14:34
 ;;1.0;WOMEN'S HEALTH;**6,10,16**;Sep 30, 1998
 ;
 ; This routine uses the following IAs:
 ; #10035 - ^DPT references     (supported)
 ; #10063 - ^%ZTLOAD            (supported)
 ; #10070 - ^XMD                (supported)
 ; #10103 - ^XLFDT              (supported)
 ;
CREATE(DFN,LRDFN,LRI,LRA,LRSS) ;
 ; Add lab test to WH file (#790.08).
 ; Called by REPORT RELEASE DATE/TIME field in:
 ; a) File 63, Field 63.08,.11
 ; b) File 63, Field 63.09,.11
 ; Input: DFN    = PATIENT DFN
 ;        LRDFN  = FILE 63 IEN (+^DPT(DFN,"LR"))
 ;        LRI    = INVERSE DATE/TIME OF TEST
 ;        LRA    = ZERO NODE OF THE CY or SP ENTRY
 ;        LRSS   = File 63 subscript (e.g., CY or SP)
 ;
 Q:($G(DFN)']"")!($G(LRDFN)']"")!($G(LRI)']"")!($G(LRA)']"")!($G(LRSS)']"")
 Q:'$D(^WV(790.02,DUZ(2)))  ;no site parameter entry
 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24)  ;lab link is NO or null
 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
 S ZTRTN="CREATEQ^WVLRLINK",ZTDESC="WV CREATE FILE 790.08 ENTRY"
 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")=""
 S ZTSAVE("LRSS")="",ZTIO=""
 S ZTDTH=$$HADD^XLFDT($H,"","","",120) ;time delay if MOVE entry point
 ; is called to delete a bogus entry first so check of lab accession
 ; x-ref doesn't fail.
 D ^%ZTLOAD
 Q
CREATEQ ; Called from CREATE above
 ; WVLOC   = WARD/CLINIC/LOCATION (FILE #44)
 ; WVDATE  = DATE OF THE PROCEDURE (FM date/time)
 ;   WVDR  = DR STRING
 ; WVPROV  = ORDERING PROVIDER (FILE #200)
 ; WVLABAN = LAB ACCESSION # (e.g., CY 99 1)
 N WVDATE,WVDR,WVLABAN,WVLABAN0,WVLOC,WVPROV
 Q:$P($G(^DPT(DFN,0)),U,2)'="F"  ;not female
 Q:'$$VNVEC()  ;vet/non-vet/eligibility code check
 S WVDATE=$P(LRA,U,1) ;date/time specimen taken
 S WVLABAN=$P(LRA,U,6) ;lab accession#
 S WVLOC=$P(LRA,U,8) ;patient location
 I WVLOC]"" S WVLOC=$$HL(WVLOC) ;convert location to File 44 pointer
 S WVPROV=$P(LRA,U,7) ;requesting provider
 ; Quit if this lab test has already been sent to FILE 790.1.
 Q:$D(^WV(790.1,"F",WVLABAN))
 I LRSS'="CY",LRSS'="SP" Q  ;not cytology or surgical pathology
 ; ===============================================================
 ; Check SNOMED codes and determine if lab test is a pap smear and
 ; can be automatically created in FILE 790.1.
 I $$SNOMED^WVSNOMED() D  Q
 .D ADD^WVSNOMED
 .Q
 ; ===============================================================
 S WVDR=".02////"_DFN
 S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV
 S WVDR=WVDR_";.1////"_$G(DUZ(2))
 S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC
 S WVDR=WVDR_";.12////"_WVDATE
 S WVDR=WVDR_";.18////.5;.19////"_DT_";.34////"_$G(DUZ(2))
 S WVDR=WVDR_";2.18////"_LRDFN_";2.19////"_LRI_";2.2////"_LRSS
 S X=WVLABAN,Y=0
 K DD,DO
 N DIC,DLAYGO
 S DIC("DR")=WVDR,DIC="^WV(790.08,",DIC(0)="ML",DLAYGO=790.08
 D FILE^DICN
 Q:Y<1  ;FILE 790.08 entry was not created
 D MAIL^WVLABWP(DFN,WVLABAN,WVPROV,LRSS) ;patient, lab accession #, provider/requestor, lab subscript (CY or SP)
 Q
EXIT ;EP
 K I,N,X
 I $D(ZTQUEUED) S ZTREQ="@"
 Q
DELETE(DFN,LRDFN,LRI,LRA,LRSS) ;
 ; Modify WH to reflect change in lab report status (no longer released).
 ; Called by REPORT RELEASE DATE/TIME field xref in:
 ; a) File 63, Field 63.08,.11
 ; b) File 63, Field 63.09,.11
 Q:'$D(DFN)!('$D(LRDFN))!('$D(LRI))!('$D(LRA))!('$D(LRSS))
 Q:'$D(^WV(790.02,DUZ(2)))  ;no site parameter entry
 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24)  ;lab link is NO or null
 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
 S ZTRTN="DELETEQ^WVLRLINK",ZTDESC="WV Change in Lab Rpt Status"
 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")=""
 S ZTSAVE("LRSS")=""
 S ZTIO="",ZTDTH=$H
 D ^%ZTLOAD
 Q
DELETEQ ; Called from DELETE above.
 N WVIEN,WVDATE,WVCMGR,WVLABAN,WVLOOP,WVMSG,WVNODE,WVPN ;,WVPROV
 N XMDUZ,XMSUB,XMTEXT,XMY ;send mail message to case manager
 S WVLABAN=$P(LRA,U,6) ;lab accession#
 Q:WVLABAN=""
 S WVIEN=$O(^WV(790.08,"B",WVLABAN,0))
 I WVIEN D DELETE^WVLABADD(WVIEN) Q  ;delete, not yet addressed
 Q:'$D(^WV(790.1,"F",WVLABAN))  ;never entered in WH procedure file
 ; Next look up lab test in WH procedure file and send warning message
 ; to WH case manager.
 S WVIEN=$O(^WV(790.1,"F",WVLABAN,0))
 Q:'$D(^WV(790.1,WVIEN,0))
 D RADMOD^WVPROC(WVIEN) ;update procedure status to "open"
 S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager
 S:WVCMGR XMY(WVCMGR)=""
 ; if no case manager, then get default case manager(s)
 I 'WVCMGR S WVLOOP=0 F  S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP  D
 .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I")
 .S:WVCMGR XMY(WVCMGR)=""
 .Q
 Q:$O(XMY(0))'>0  ;no case manager(s)
 ;S:WVPROV XMY(WVPROV)=""
 S WVNODE=$G(^WV(790.1,+WVIEN,0))
 S WVPN=$E($P(WVNODE,U,1),1,2),WVPN=$$PN(WVPN)
 S XMDUZ=.5 ;message sender
 S XMSUB="Lab Report for WH patient is UNVERIFIED"
 S WVMSG(1)="        Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")"
 S WVMSG(2)=" WH Accession #: "_$P(WVNODE,U,1)_"  Procedure Type: "_$S(WVPN]"":WVPN,1:"Unknown")
 S WVMSG(3)="Lab Accession #: "_WVLABAN
 S WVMSG(4)=" "
 S WVMSG(5)="NOTE: This lab test has been UNVERIFIED in the LAB package."
 S WVMSG(6)=" "
 S WVMSG(7)="The status of the associated WH procedure has been changed to 'open',"
 S WVMSG(8)="You may wish to contact Lab Service to find out the reason for the change."
 S WVMSG(9)="Please use the 'Edit a Procedure' option in the WOMEN'S HEALTH package"
 S WVMSG(10)="to modify/close this procedure."
 S XMTEXT="WVMSG("
 D ^XMD
 I $D(ZTQUEUED) S ZTREQ="@"
 Q
HL(WVLOC) ; Get Hospital Location file (#44) pointer
 N WVARRAY,WVERR
 D FIND^DIC(44,"","","X",WVLOC,"","C","","","WVARRAY","WVERR")
 I +$G(WVARRAY("DILIST",0))=1 Q +WVARRAY("DILIST",2,1)
 Q ""
PN(X) ; Get procedure name
 I X="" Q ""
 S X=$O(^WV(790.2,"D",X,0)) ;look at abbreviation x-ref
 I 'X Q ""
 S X=$P($G(^WV(790.2,+X,0)),U,1)
 Q X
 ;
MOVE(DFN,LRDFN,LRI,LRA,LRSS) ; Called from Lab package when a lab accession is
 ; moved from one patient to another because the test was originally
 ; associated to the wrong patient.
 Q:'$D(DFN)!('$D(LRDFN))!('$D(LRI))!('$D(LRA))!('$D(LRSS))
 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
 S ZTRTN="MOVEQ^WVLRLINK",ZTDESC="WV Lab Accession moved to another patient"
 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")=""
 S ZTSAVE("LRSS")="",ZTIO="",ZTDTH=$H
 D ^%ZTLOAD
 Q
MOVEQ ; Called from MOVE above
 N DA,DIE,DR
 N WVACCN,WVCMGR,WVDFN,WVIEN,WVLABAN,WVLOOP,WVNIEN,WVNODE,WVPIEN,WVPN,WVRD
 S WVLABAN=$P(LRA,U,6) ;lab accession#
 Q:WVLABAN=""
 S WVIEN=$O(^WV(790.08,"B",WVLABAN,0)) ;check WV LAB TESTS first
 I WVIEN D  Q  ;fix/delete File 790.8 entry, not a file (790.1) entry
 .D DELETE^WVLABADD(WVIEN)
 .Q
 ;
 S WVPIEN=$O(^WV(790.1,"F",WVLABAN,0)) ;check WH Procedure file
 Q:'WVPIEN  ;lab test was not converted into a WH procedure
 S WVNODE=$G(^WV(790.1,WVPIEN,0))
 S WVACCN=$P(WVNODE,U,1) ;WH accession#
 S WVDFN=+$P(WVNODE,U,2) ;DFN for existing patient
 Q:WVACCN=""
 S WVRD=$$RDC("Error/disregard")
 ; delete links to lab test entry so wrong lab report doesn't display
 S DIE="^WV(790.1,",DA=WVPIEN,DR=".05////"_WVRD_";2.17///@;2.18///@;2.19///@;2.2///@"
 ; include amended comment?
 D ^DIE
 S WVNIEN=$O(^WV(790.4,"C",WVACCN,0)) ;notification for that procedure?
 ; Send a mail message to case manager about patient change
 D MOVE^WVLABWP(WVDFN,WVNODE,WVNIEN)
 I $D(ZTQUEUED) S ZTREQ="@"
 Q
RDC(WVRD) ; Return ien of Result/Diagnosis code
 ; input text of result/diagnois
 I WVRD="" Q ""
 Q +$O(^WV(790.31,"B",WVRD,0))
 ;
VNVEC() ; Veteran/Non-Veteran/Eligibility Code check
 ; DFN must be defined
 ; Returns 1 - veteran
 ;             include all non-vets flag set to YES
 ;             non-vet patient's eligibility code is on list to track 
 N WVALL,WVLOOP,X,Y
 I $E($$VET^WVUTL1A(DFN))="Y" Q 1  ;veteran
 S WVALL=$P($G(^WV(790.02,DUZ(2),0)),U,26) ;include all non-vets
 I WVALL=1!(WVALL="") Q 1  ;1=YES
 S WVLOOP=+$$ELIG^WVUTL9(DFN) ;internal^external elig code
 I 'WVLOOP Q 0  ;no eligibility code
 I $D(^WV(790.02,DUZ(2),6,WVLOOP)) Q 1  ;code is on list to be tracked
 Q 0
 ;