WVLABADD ;HCIOFO/FT - SAVE A LAB TEST AS A WH PROCEDURE ;07/28/2017 11:27
;;1.0;WOMEN'S HEALTH;**6,24**;Sep 30, 1998;Build 582
;
EN ; Entry point from [WV SAVE LAB TEST] option.
; Converts a lab test stored in the WV LAB TESTS file (#790.08)
; into an entry in the WV PROCEDURES file (#790.1)
N WVDICB
S (WVDICB,WVPOP)=0
F D Q:WVPOP
.D SELECT Q:WVPOP
.D DISPLAY
.Q
D KILL
Q
SELECT ; Select a lab test entry from File 790.08
N DIC,DTOUT,DUOUT,WVDFN
S DIC="^WV(790.08,",DIC(0)="AEMQZ"
S DIC("A")="Select Lab Test Accession#: "
D DEFAULT
D ^DIC
I Y<0!($D(DTOUT))!($D(DUOUT)) S WVPOP=1 Q
S WVIEN=+Y
S WVDFN=+$P(^WV(790.08,+Y,0),U,2)
S:WVDFN ^DISV(DUZ,"^DPT(")=WVDFN ;space bar/return save for File 790
Q
DISPLAY ; Display lab test data
Q:'$G(WVIEN)
N LRDFN,LRSS,WVDATE,WVLABACC,WVNAME,WVNODE,WVVALUE
S WVNODE=$G(^WV(790.08,+WVIEN,0))
Q:WVNODE=""
S WVLABACC=$P(WVNODE,U,1) ;lab accession#
S LRDFN=$P(WVNODE,U,36) ;File 63 ien (+^DPT(DFN,"LR"))
S WVDATE=$P(WVNODE,U,37) ;File 63 inverse date/time
S LRSS=$P(WVNODE,U,38) ;File 63 subscript (CY or SP)
I WVLABACC=""!(LRDFN="")!(WVDATE="")!(LRSS="") D Q
.W !,"Sorry, lab test "_WVLABACC_" is not available after all."
.W !,"Will delete this lab test from the list of choices.",!
.D DELETE(WVIEN)
.Q
I $D(^WV(790.1,"F",WVLABACC)) D Q
.S WVVALUE=$O(^WV(790.1,"F",WVLABACC,0))
.S WVVALUE=$P($G(^WV(790.1,WVVALUE,0)),U,1)
.W !,"Sorry, lab test "_WVLABACC_" is already saved as a procedure."
.W !,"It is logged as WH accession# "_WVVALUE_"."
.W !,"Will delete this lab test from the list of choices.",!
.D DELETE(WVIEN)
.Q
K ^TMP("WVLAB",$J)
D HS^WVLABWP ;call Health Summary, returns lab data in ^TMP("WVLAB",$J)
I '$D(^TMP("WVLAB",$J)) D Q
.W !,"Sorry, lab test data is not available for this choice."
.W !,"Will delete this lab test from the list of choices.",!
.D DELETE(WVIEN)
.Q
S WVNAME=$P(WVNODE,U,2) ;dfn
S WVNAME=$$GET1^DIQ(2,WVNAME,.01,"E") ;get patient name for Browser call
D BROWSE^DDBR("^TMP(""WVLAB"",$J)","N",WVNAME)
KEEP ; Save lab test as procedure OR delete lab test from File 790.08 OR
; ignore it for now.
N DIR
S DIR(0)="S^A:add to the WH package;D:delete from the list of choices;I:ignore for now"
S DIR("A")="What action should be taken with this lab test"
S DIR("?",1)="Please determine what to do with this lab test."
S DIR("?",2)=" Ignore this lab test for now."
S DIR("?",3)=" Delete from the list. It shouldn't be a Women's Health procedure."
S DIR("?")=" Add this lab test as a Women's Health procedure entry."
D ^DIR
I $D(DIRUT) S WVPOP=1 Q
I Y="I" Q
I Y="D" D DELETE(WVIEN) Q
I Y="A" D CONVERT
Q
CONVERT ; Add the lab test data to the WV PROCEDURE file (#790.1)
Q:'$G(WVIEN)
N DFN,DIC,DTOUT,DUOUT
N WVDATE,WVDR,WVERR,WVNODE,WVPROC
S WVNODE=$G(^WV(790.08,+WVIEN,0))
S DIC="^WV(790.2,",DIC(0)="AEMQZ"
S DIC("A")="Select the procedure type for this lab test: "
D ^DIC
W !
I Y<0!($D(DTOUT))!($D(DUOUT)) S WVPOP=1 Q
S WVPROC=+Y
S WVERR=1,DFN=$P(WVNODE,U,2),WVDATE=$P(WVNODE,U,12)
I '$D(^WV(790,DFN,0)) D ;add patient to File 790, if not there
.D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR)
.Q
Q:WVERR<0 ;quit if new patient could not be added to File 790
D FIND^WVLABAD1 ;check for 'unlinked' entry in File 790.1
I $D(^WV(790.1,"F",WVLABACC)) D Q ;link was made to existing entry
.D DELETE(WVIEN) ;delete lab test from list of choices
.S Y=+$O(^WV(790.1,"F",WVLABACC,0)) ;ien of procedure entry
.D EDIT ;edit procedure entry
.Q
S WVDR=".02////"_DFN
S WVDR=WVDR_";.04////"_WVPROC ;File 790.2 pointer
S:$P(WVNODE,U,7)]"" WVDR=WVDR_";.07////"_$P(WVNODE,U,7) ;provider
S WVDR=WVDR_";.1////"_$G(DUZ(2)) ;health care facility
S:$P(WVNODE,U,11)]"" WVDR=WVDR_";.11////"_$P(WVNODE,U,11) ;patient location
S WVDR=WVDR_";.12////"_$P(WVNODE,U,12) ;procedure date/time
S WVDR=WVDR_";.14////"_"o" ;status
S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date
S WVDR=WVDR_";.34////"_$G(DUZ(2)) ;accessioning facility
S WVDR=WVDR_";2.17////"_$P(WVNODE,U,1) ;lab accession#
S WVDR=WVDR_";2.18////"_$P(WVNODE,U,36) ;Lab Data file (#63) pointer
S WVDR=WVDR_";2.19////"_$P(WVNODE,U,37) ;Lab Data file inverse d/t
S WVDR=WVDR_";2.2////"_$P(WVNODE,U,38) ;Lab Data file subscript (CY/SP)
; add procedure to File 790.1
D NEW2^WVPROC(DFN,WVPROC,WVDATE,WVDR,"","",.WVERR)
I Y D DELETE(WVIEN)
I Y D EDIT
Q
KILL ; Kill variables
D KILLALL^WVUTL8
K ^TMP("WVLAB",$J)
Q
DELETE(WVIEN) ; Delete an entry from File 790.08
Q:'$G(WVIEN)
N DA,DIK,Y
S DA=WVIEN,DIK="^WV(790.08,"
D ^DIK
Q
EDIT ; Edit WV PROCEDURE (#790.1) file entry
Q:'$G(Y)
D LT^WVPROC ;edit the new entry
S WVPOP=0 ;reset WVPOP which is killed by ^WVPROC call
Q
DEFAULT ; Find next default look-up value.
; WVQUIT - ien of File 790.08 entry
; WVDICB - last entry checked (don't show an entry they bypassed)
N WVLOOP,WVNODE,WVQUIT
Q:$G(WVDICB)=""
S WVQUIT=0,WVLOOP=+WVDICB
F S WVLOOP=$O(^WV(790.08,WVLOOP)) Q:'WVLOOP D Q:WVQUIT
.S WVNODE=$G(^WV(790.08,WVLOOP,0)) Q:WVNODE=""
.I $P(WVNODE,U,7)=DUZ D Q ;duz is requesting provider
..S (WVDICB,WVQUIT)=WVLOOP
..Q
.I $P($G(^WV(790,+$P(WVNODE,U,2),0)),U,10)=DUZ D ;case mgr
..S (WVDICB,WVQUIT)=WVLOOP
..Q
.Q
S DIC("B")=$S(WVQUIT:$P(^WV(790.08,+WVQUIT,0),U,1),1:"")
K:DIC("B")="" DIC("B")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVLABADD 5426 printed Apr 09, 2024@21:50:11 Page 2
WVLABADD ;HCIOFO/FT - SAVE A LAB TEST AS A WH PROCEDURE ;07/28/2017 11:27
+1 ;;1.0;WOMEN'S HEALTH;**6,24**;Sep 30, 1998;Build 582
+2 ;
EN ; Entry point from [WV SAVE LAB TEST] option.
+1 ; Converts a lab test stored in the WV LAB TESTS file (#790.08)
+2 ; into an entry in the WV PROCEDURES file (#790.1)
+3 NEW WVDICB
+4 SET (WVDICB,WVPOP)=0
+5 FOR
Begin DoDot:1
+6 DO SELECT
if WVPOP
QUIT
+7 DO DISPLAY
+8 QUIT
End DoDot:1
if WVPOP
QUIT
+9 DO KILL
+10 QUIT
SELECT ; Select a lab test entry from File 790.08
+1 NEW DIC,DTOUT,DUOUT,WVDFN
+2 SET DIC="^WV(790.08,"
SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Select Lab Test Accession#: "
+4 DO DEFAULT
+5 DO ^DIC
+6 IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
SET WVPOP=1
QUIT
+7 SET WVIEN=+Y
+8 SET WVDFN=+$PIECE(^WV(790.08,+Y,0),U,2)
+9 ;space bar/return save for File 790
if WVDFN
SET ^DISV(DUZ,"^DPT(")=WVDFN
+10 QUIT
DISPLAY ; Display lab test data
+1 if '$GET(WVIEN)
QUIT
+2 NEW LRDFN,LRSS,WVDATE,WVLABACC,WVNAME,WVNODE,WVVALUE
+3 SET WVNODE=$GET(^WV(790.08,+WVIEN,0))
+4 if WVNODE=""
QUIT
+5 ;lab accession#
SET WVLABACC=$PIECE(WVNODE,U,1)
+6 ;File 63 ien (+^DPT(DFN,"LR"))
SET LRDFN=$PIECE(WVNODE,U,36)
+7 ;File 63 inverse date/time
SET WVDATE=$PIECE(WVNODE,U,37)
+8 ;File 63 subscript (CY or SP)
SET LRSS=$PIECE(WVNODE,U,38)
+9 IF WVLABACC=""!(LRDFN="")!(WVDATE="")!(LRSS="")
Begin DoDot:1
+10 WRITE !,"Sorry, lab test "_WVLABACC_" is not available after all."
+11 WRITE !,"Will delete this lab test from the list of choices.",!
+12 DO DELETE(WVIEN)
+13 QUIT
End DoDot:1
QUIT
+14 IF $DATA(^WV(790.1,"F",WVLABACC))
Begin DoDot:1
+15 SET WVVALUE=$ORDER(^WV(790.1,"F",WVLABACC,0))
+16 SET WVVALUE=$PIECE($GET(^WV(790.1,WVVALUE,0)),U,1)
+17 WRITE !,"Sorry, lab test "_WVLABACC_" is already saved as a procedure."
+18 WRITE !,"It is logged as WH accession# "_WVVALUE_"."
+19 WRITE !,"Will delete this lab test from the list of choices.",!
+20 DO DELETE(WVIEN)
+21 QUIT
End DoDot:1
QUIT
+22 KILL ^TMP("WVLAB",$JOB)
+23 ;call Health Summary, returns lab data in ^TMP("WVLAB",$J)
DO HS^WVLABWP
+24 IF '$DATA(^TMP("WVLAB",$JOB))
Begin DoDot:1
+25 WRITE !,"Sorry, lab test data is not available for this choice."
+26 WRITE !,"Will delete this lab test from the list of choices.",!
+27 DO DELETE(WVIEN)
+28 QUIT
End DoDot:1
QUIT
+29 ;dfn
SET WVNAME=$PIECE(WVNODE,U,2)
+30 ;get patient name for Browser call
SET WVNAME=$$GET1^DIQ(2,WVNAME,.01,"E")
+31 DO BROWSE^DDBR("^TMP(""WVLAB"",$J)","N",WVNAME)
KEEP ; Save lab test as procedure OR delete lab test from File 790.08 OR
+1 ; ignore it for now.
+2 NEW DIR
+3 SET DIR(0)="S^A:add to the WH package;D:delete from the list of choices;I:ignore for now"
+4 SET DIR("A")="What action should be taken with this lab test"
+5 SET DIR("?",1)="Please determine what to do with this lab test."
+6 SET DIR("?",2)=" Ignore this lab test for now."
+7 SET DIR("?",3)=" Delete from the list. It shouldn't be a Women's Health procedure."
+8 SET DIR("?")=" Add this lab test as a Women's Health procedure entry."
+9 DO ^DIR
+10 IF $DATA(DIRUT)
SET WVPOP=1
QUIT
+11 IF Y="I"
QUIT
+12 IF Y="D"
DO DELETE(WVIEN)
QUIT
+13 IF Y="A"
DO CONVERT
+14 QUIT
CONVERT ; Add the lab test data to the WV PROCEDURE file (#790.1)
+1 if '$GET(WVIEN)
QUIT
+2 NEW DFN,DIC,DTOUT,DUOUT
+3 NEW WVDATE,WVDR,WVERR,WVNODE,WVPROC
+4 SET WVNODE=$GET(^WV(790.08,+WVIEN,0))
+5 SET DIC="^WV(790.2,"
SET DIC(0)="AEMQZ"
+6 SET DIC("A")="Select the procedure type for this lab test: "
+7 DO ^DIC
+8 WRITE !
+9 IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
SET WVPOP=1
QUIT
+10 SET WVPROC=+Y
+11 SET WVERR=1
SET DFN=$PIECE(WVNODE,U,2)
SET WVDATE=$PIECE(WVNODE,U,12)
+12 ;add patient to File 790, if not there
IF '$DATA(^WV(790,DFN,0))
Begin DoDot:1
+13 DO AUTOADD^WVPATE(DFN,DUZ(2),.WVERR)
+14 QUIT
End DoDot:1
+15 ;quit if new patient could not be added to File 790
if WVERR<0
QUIT
+16 ;check for 'unlinked' entry in File 790.1
DO FIND^WVLABAD1
+17 ;link was made to existing entry
IF $DATA(^WV(790.1,"F",WVLABACC))
Begin DoDot:1
+18 ;delete lab test from list of choices
DO DELETE(WVIEN)
+19 ;ien of procedure entry
SET Y=+$ORDER(^WV(790.1,"F",WVLABACC,0))
+20 ;edit procedure entry
DO EDIT
+21 QUIT
End DoDot:1
QUIT
+22 SET WVDR=".02////"_DFN
+23 ;File 790.2 pointer
SET WVDR=WVDR_";.04////"_WVPROC
+24 ;provider
if $PIECE(WVNODE,U,7)]""
SET WVDR=WVDR_";.07////"_$PIECE(WVNODE,U,7)
+25 ;health care facility
SET WVDR=WVDR_";.1////"_$GET(DUZ(2))
+26 ;patient location
if $PIECE(WVNODE,U,11)]""
SET WVDR=WVDR_";.11////"_$PIECE(WVNODE,U,11)
+27 ;procedure date/time
SET WVDR=WVDR_";.12////"_$PIECE(WVNODE,U,12)
+28 ;status
SET WVDR=WVDR_";.14////"_"o"
+29 ;entering user and date
SET WVDR=WVDR_";.18////.5;.19////"_DT
+30 ;accessioning facility
SET WVDR=WVDR_";.34////"_$GET(DUZ(2))
+31 ;lab accession#
SET WVDR=WVDR_";2.17////"_$PIECE(WVNODE,U,1)
+32 ;Lab Data file (#63) pointer
SET WVDR=WVDR_";2.18////"_$PIECE(WVNODE,U,36)
+33 ;Lab Data file inverse d/t
SET WVDR=WVDR_";2.19////"_$PIECE(WVNODE,U,37)
+34 ;Lab Data file subscript (CY/SP)
SET WVDR=WVDR_";2.2////"_$PIECE(WVNODE,U,38)
+35 ; add procedure to File 790.1
+36 DO NEW2^WVPROC(DFN,WVPROC,WVDATE,WVDR,"","",.WVERR)
+37 IF Y
DO DELETE(WVIEN)
+38 IF Y
DO EDIT
+39 QUIT
KILL ; Kill variables
+1 DO KILLALL^WVUTL8
+2 KILL ^TMP("WVLAB",$JOB)
+3 QUIT
DELETE(WVIEN) ; Delete an entry from File 790.08
+1 if '$GET(WVIEN)
QUIT
+2 NEW DA,DIK,Y
+3 SET DA=WVIEN
SET DIK="^WV(790.08,"
+4 DO ^DIK
+5 QUIT
EDIT ; Edit WV PROCEDURE (#790.1) file entry
+1 if '$GET(Y)
QUIT
+2 ;edit the new entry
DO LT^WVPROC
+3 ;reset WVPOP which is killed by ^WVPROC call
SET WVPOP=0
+4 QUIT
DEFAULT ; Find next default look-up value.
+1 ; WVQUIT - ien of File 790.08 entry
+2 ; WVDICB - last entry checked (don't show an entry they bypassed)
+3 NEW WVLOOP,WVNODE,WVQUIT
+4 if $GET(WVDICB)=""
QUIT
+5 SET WVQUIT=0
SET WVLOOP=+WVDICB
+6 FOR
SET WVLOOP=$ORDER(^WV(790.08,WVLOOP))
if 'WVLOOP
QUIT
Begin DoDot:1
+7 SET WVNODE=$GET(^WV(790.08,WVLOOP,0))
if WVNODE=""
QUIT
+8 ;duz is requesting provider
IF $PIECE(WVNODE,U,7)=DUZ
Begin DoDot:2
+9 SET (WVDICB,WVQUIT)=WVLOOP
+10 QUIT
End DoDot:2
QUIT
+11 ;case mgr
IF $PIECE($GET(^WV(790,+$PIECE(WVNODE,U,2),0)),U,10)=DUZ
Begin DoDot:2
+12 SET (WVDICB,WVQUIT)=WVLOOP
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
if WVQUIT
QUIT
+15 SET DIC("B")=$SELECT(WVQUIT:$PIECE(^WV(790.08,+WVQUIT,0),U,1),1:"")
+16 if DIC("B")=""
KILL DIC("B")
+17 QUIT
