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