WVPROC ;HCIOFO/FT,JR - WV ADD/EDIT WV PROCEDURE; ;5/10/99 10:22
;;1.0;WOMEN'S HEALTH;**3,6**;Sep 30, 1998
;; Original routine created by IHS/ANMC/MWR
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY VARIOUS OPTIONS TO ADD/EDIT PROCEDURES.
;
;
ADDNEW ;EP
;---> CALLED BY OPTION: "WV ADD A NEW PROCEDURE".
D SETVARS^WVUTL5 S WVPOP1=0
N DA,DIC,DIE,Y
F D Q:WVPOP1
.D NEW
.Q:WVPOP
.D EDIT2^WVPROC1(DA,.WVPOP)
.Q:WVPOP
.D PCDVARS^WVUTL3(DA,1)
.D NORMAL^WVPROC1
D EXIT
Q
;
EXIT ;EP
D KILLALL^WVUTL8
Q
;
;
NEW ;EP
;---> SELECT A PATIENT.
D SETVARS^WVUTL5 K DIC
D TITLE^WVUTL5("ADD A NEW PROCEDURE")
NEWNT ;EP
;---> ENTER NEW WITHOUT A TITLE (ALLOWS OTHER TITLES, E.G., HISTORICAL)
;---> LOOKUP AND SELECT PATIENT FROM WV PATIENT FILE.
; Quit if no default case manager
I '$$DCM^WVUTL9(DUZ(2)) D NODCM^WVUTL9 S (WVPOP,WVPOP1)=1 Q
D PATLKUP^WVUTL8(.Y,"ADD")
I Y<0 S (WVPOP,WVPOP1)=1 Q
S WVDFN=+Y
;
NEW1 ;EP
;---> ADD A NEW PROCEDURE.
;---> PATIENT SELECTED ALREADY BUT NOT PROCEDURE.
;---> REQUIRED VARIABLE: WVDFN
;
;---> NOW SELECT PROCEDURE TYPE FROM WV PROCEDURE TYPE FILE.
N A,WVPCDN,S
S A=" Select PROCEDURE: "
;---> SCREEN: ACTIVE FIELD CAN BE "YES" OR NULL, BUT NOT "NO".
S S="I $P($G(^WV(790.02,DUZ(2),Y)),U)'=0"
D DIC^WVFMAN(790.2,"QEMA",.Y,A,"PAP SMEAR",S,"",.WVPOP)
Q:Y<0
;---> WVPCDN=IEN OF PROCEDURE TYPE, FILE 790.2.
S WVPCDN=+Y
;
;---> IF IT'S A UNILATERAL MAMMOGRAM, PROMPT FOR LEFT OR RIGHT.
S WVLFRT=""
I WVPCDN=26 D I $D(DIRUT) S WVPOP=1 Q
.N DIR
.S DIR("?")=" Select LEFT or RIGHT for this Unilateral Mammogram."
.S DIR(0)="SAM^l:LEFT;r:RIGHT",DIR("A")=" LEFT OR RIGHT: "
.D ^DIR K DIR
.Q:$D(DIRUT)
.S WVLFRT=Y
;
;---> IF IT'S A COLPOSCOPY, PROMPT FOR PAP THAT INITIATED IT.
S WVPPAP=""
I WVPCDN=2 D Q:WVPOP
.W !!?3,"Select the PAP Smear that initiated this Colposcopy."
.N A,S
.S DIC("?",1)="If a previous abnormal PAP Smear was the reason for"
.S DIC("?")="this Colposcopy, enter the Accession# of that PAP here."
.S A=" PAP Smear: ",S="D PAPSCRN^WVUTL2"
.D DIC^WVFMAN(790.1,"QEMA",.Y,A,"",S,"",.WVPOP)
.Q:Y<0
.;---> WVPPAP=IEN OF PREVIOUS PAP IN WV PROCEDURE FILE 790.1.
.S WVPPAP=+Y
;
;---> ASK DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
D DATECHK Q:WVPOP
D NEW2(WVDFN,WVPCDN,WVPCDT,"",WVPPAP,.DA,.WVERROR)
Q
;
NEW2(DFN,PCDIEN,DATE,DRSTRG,PREVPAP,DA,ERROR) ;EP
;---> ADD A NEW PROCEDURE.
;---> PATIENT AND PROCEDURE ALREADY SELECTED.
;---> NOW GENERATE ACCESSION# FOR WV PROCEDURE FILE ENTRY.
;---> REQUIRED VARIABLES: DFN=IEN IN WV PATIENT FILE
;---> PCDIEN=IEN OF PROCEDURE TYPE (#790.2).
;
S X=$$ACCSSN^WVUTL5(PCDIEN) N DIC
I X']"" D Q
.S ERROR=-1
.Q:$D(ZTQUEUED) ;quit if a background (tasked) job
.W !!?5,*7,"UNABLE TO GENERATE ACCESSION#. CONTACT YOUR SITE MANAGER."
.D DIRZ^WVUTL3
.Q
;
I $G(DRSTRG)']"" D
.;---> DEFAULTS: DATE OF PROCEDURE IS TODAY, STATUS IS OPEN.
.S DRSTRG=".02////"_DFN_";.04////"_PCDIEN
.S DRSTRG=DRSTRG_";.09///"_$S($D(WVLFRT):WVLFRT,1:"")_";.12///"_DATE
.S DRSTRG=DRSTRG_";.14///o"
.S DRSTRG=DRSTRG_";.18////"_DUZ_";.19///T;.3////"_$G(PREVPAP)
.S DRSTRG=DRSTRG_";.34////"_$G(DUZ(2))
;
D FILE^WVFMAN(790.1,DRSTRG,"ML",X,790,.Y)
;---> IF Y<0, CHECK PERMISSIONS.
I Y<0 D Q
.S ERROR=Y
.Q:$D(ZTQUEUED) ;quit if a background (tasked) job
.W !?5,*7,"UNABLE TO CREATE NEW PROCEDURE."
.D DIRZ^WVUTL3 S WVPOP=1
.Q
S DA=+Y
Q
;
;
EDIT ;EP
;---> CALLED BY OPTION: "WV EDIT PROCEDURE".
;---> EDIT AN EXISTING PROCEDURE.
D TITLE^WVUTL5("EDIT A PROCEDURE")
D LKUPPCD(.Y)
Q:Y<0
LT ; Called from WVLABADD routine to immediately edit a procedure created
; from a lab test.
;---> DA=IEN OF PROCEDURE IN PROCEDURE FILE 790.1.
S DA=+Y
I $P($G(^WV(790.1,+DA,0)),U,15)]"" D ^WVRADWP
I $P($G(^WV(790.1,+DA,2)),U,17)]"" D
.D ^WVLABWP
.Q:'$D(^TMP("WVLAB",$J))
.S WVLOOP=0
.F S WVLOOP=$O(^TMP("WVLAB",$J,WVLOOP)) Q:WVLOOP'>0 D
..S ^WV(790.1,DA,9,WVLOOP,0)=$G(^TMP("WVLAB",$J,WVLOOP,0)) S WVLOOP(1)=WVLOOP
..Q
.S ^WV(790.1,DA,9,0)="^^"_$G(WVLOOP(1))_"^"_$G(WVLOOP(1))
.K ^TMP("WVLAB",$J)
.Q
D EDIT2^WVPROC1(DA,.WVPOP) Q:WVPOP!($D(WVNOFOL))
D EX^WVRADWP
D PCDVARS^WVUTL3(DA,1)
D NORMAL^WVPROC1
D EXIT
Q
;
;
HISTORIC ;EP
;---> CALLED BY OPTION: "WV ADD AN HISTORICAL PROCEDURE".
;---> ADD HISTORICAL PROCEDURES (NO PROVIDER, WARD/CLINIC, FACILITY).
D SETVARS^WVUTL5 S WVPOP1=0 N DA,DIE,Y
F D Q:WVPOP1
.D TITLE^WVUTL5("ENTER HISTORICAL DATA")
.D NEWNT W !
.Q:(WVPOP!('$G(DA)))
.S WVPN=$P(^WV(790.1,DA,0),U,4)
.S DR=".05;.08;.1;.14////c"
.D DIE^WVFMAN(790.1,DR,DA,.WVPOP)
D EXIT
Q
;
;
LABEDIT ;EP
;---> CALLED BY OPTION: "WV LAB EDIT PROCEDURE".
S WVNOFOL=1 D EDIT,EXIT
Q
;
;
RADMOD(DA) ;EP
;---> MODIFY A PROCEDURE THAT WAS IMPORTED FROM RADIOLOGY AND
;---> HAS BEEN CHANGED.
;---> DA=IEN OF PROCEDURE IN WV PROCEDURE FILE #790.1.
Q:'$G(DA)
S DR=".13////"_DT_";.14////o"
D DIE^WVFMAN(790.1,DR,DA,.WVPOP)
Q
;
;
LKUPPCD(Y) ;EP
;---> LOOKUP A PROCEDURE.
N A
D SETVARS^WVUTL5
S A="Select ACCESSION# or PATIENT NAME: "
D DIC^WVFMAN(790.1,"QEMA",.Y,A,"","","",.WVPOP)
Q
;
DATECHK ;EP
;---> PROMPT FOR DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
N WVNEW,DIR,DIRUT,N,Y S WVPOP=0
S DIR("?",1)=" Enter the date on which this procedure was performed:"
S DIR("?")=" (NOTE: Dates in the future may NOT be entered.)"
S DIR(0)="DA^0:DT:EX",DIR("A")=" Select DATE: ",DIR("B")="TODAY"
D ^DIR K DIR
I Y<1 S WVPOP=1 Q
S WVPCDT=Y D DD^%DT W " ",Y
S N=0,WVNEW=0
F S N=$O(^WV(790.1,"C",WVDFN,N)) Q:('N)!(WVPOP)!(WVNEW) D
.S Y=^WV(790.1,N,0)
.;---> QUIT IF NOT THE SAME PROCEDURE TYPE.
.Q:$P(Y,U,4)'=WVPCDN
.;---> QUIT IF NOT THE SAME PROCEDURE DATE.
.Q:$P(Y,U,12)'=WVPCDT
.;---> QUIT IF THIS PROCEDURE HAS A RESULT/DIAG OF "ERROR/DISREGARD".
.Q:$P(Y,U,5)=8
.N WVPN S WVPN=$P(^WV(790.2,$P(Y,U,4),0),U)
.W !!?5,"A ",WVPN," already exists for this patient on this date,"
.W !?5,"with an Accession# of ",$P(Y,U)
.W ". You may edit that procedure by"
.W !?5,"calling up ",$P(Y,U)," under the ""Edit a Procedure"" option."
.W !?5,"Or you may enter another ",WVPN," for this patient"
.W !?5,"on this date."
.W !!?5,"Do you REALLY want to add another ",WVPN," for this patient"
.W !?5,"on this date?"
.S DIR("?")=" Enter NO to avoid adding another "_WVPN
.S DIR("?")=DIR("?")_" on this date."
.S DIR(0)="Y",DIR("A")=" Enter Yes or No",DIR("B")="NO"
.D ^DIR K DIR
.I $D(DIRUT)!('Y) S WVPOP=1 Q
.S WVNEW=1
Q
;
ERROR1 ;EP
W !!?10,*7,"NEW PROCEDURE ENTRY FOR THIS PATIENT FAILED."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVPROC 6798 printed Dec 13, 2024@02:47:25 Page 2
WVPROC ;HCIOFO/FT,JR - WV ADD/EDIT WV PROCEDURE; ;5/10/99 10:22
+1 ;;1.0;WOMEN'S HEALTH;**3,6**;Sep 30, 1998
+2 ;; Original routine created by IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; CALLED BY VARIOUS OPTIONS TO ADD/EDIT PROCEDURES.
+5 ;
+6 ;
ADDNEW ;EP
+1 ;---> CALLED BY OPTION: "WV ADD A NEW PROCEDURE".
+2 DO SETVARS^WVUTL5
SET WVPOP1=0
+3 NEW DA,DIC,DIE,Y
+4 FOR
Begin DoDot:1
+5 DO NEW
+6 if WVPOP
QUIT
+7 DO EDIT2^WVPROC1(DA,.WVPOP)
+8 if WVPOP
QUIT
+9 DO PCDVARS^WVUTL3(DA,1)
+10 DO NORMAL^WVPROC1
End DoDot:1
if WVPOP1
QUIT
+11 DO EXIT
+12 QUIT
+13 ;
EXIT ;EP
+1 DO KILLALL^WVUTL8
+2 QUIT
+3 ;
+4 ;
NEW ;EP
+1 ;---> SELECT A PATIENT.
+2 DO SETVARS^WVUTL5
KILL DIC
+3 DO TITLE^WVUTL5("ADD A NEW PROCEDURE")
NEWNT ;EP
+1 ;---> ENTER NEW WITHOUT A TITLE (ALLOWS OTHER TITLES, E.G., HISTORICAL)
+2 ;---> LOOKUP AND SELECT PATIENT FROM WV PATIENT FILE.
+3 ; Quit if no default case manager
+4 IF '$$DCM^WVUTL9(DUZ(2))
DO NODCM^WVUTL9
SET (WVPOP,WVPOP1)=1
QUIT
+5 DO PATLKUP^WVUTL8(.Y,"ADD")
+6 IF Y<0
SET (WVPOP,WVPOP1)=1
QUIT
+7 SET WVDFN=+Y
+8 ;
NEW1 ;EP
+1 ;---> ADD A NEW PROCEDURE.
+2 ;---> PATIENT SELECTED ALREADY BUT NOT PROCEDURE.
+3 ;---> REQUIRED VARIABLE: WVDFN
+4 ;
+5 ;---> NOW SELECT PROCEDURE TYPE FROM WV PROCEDURE TYPE FILE.
+6 NEW A,WVPCDN,S
+7 SET A=" Select PROCEDURE: "
+8 ;---> SCREEN: ACTIVE FIELD CAN BE "YES" OR NULL, BUT NOT "NO".
+9 SET S="I $P($G(^WV(790.02,DUZ(2),Y)),U)'=0"
+10 DO DIC^WVFMAN(790.2,"QEMA",.Y,A,"PAP SMEAR",S,"",.WVPOP)
+11 if Y<0
QUIT
+12 ;---> WVPCDN=IEN OF PROCEDURE TYPE, FILE 790.2.
+13 SET WVPCDN=+Y
+14 ;
+15 ;---> IF IT'S A UNILATERAL MAMMOGRAM, PROMPT FOR LEFT OR RIGHT.
+16 SET WVLFRT=""
+17 IF WVPCDN=26
Begin DoDot:1
+18 NEW DIR
+19 SET DIR("?")=" Select LEFT or RIGHT for this Unilateral Mammogram."
+20 SET DIR(0)="SAM^l:LEFT;r:RIGHT"
SET DIR("A")=" LEFT OR RIGHT: "
+21 DO ^DIR
KILL DIR
+22 if $DATA(DIRUT)
QUIT
+23 SET WVLFRT=Y
End DoDot:1
IF $DATA(DIRUT)
SET WVPOP=1
QUIT
+24 ;
+25 ;---> IF IT'S A COLPOSCOPY, PROMPT FOR PAP THAT INITIATED IT.
+26 SET WVPPAP=""
+27 IF WVPCDN=2
Begin DoDot:1
+28 WRITE !!?3,"Select the PAP Smear that initiated this Colposcopy."
+29 NEW A,S
+30 SET DIC("?",1)="If a previous abnormal PAP Smear was the reason for"
+31 SET DIC("?")="this Colposcopy, enter the Accession# of that PAP here."
+32 SET A=" PAP Smear: "
SET S="D PAPSCRN^WVUTL2"
+33 DO DIC^WVFMAN(790.1,"QEMA",.Y,A,"",S,"",.WVPOP)
+34 if Y<0
QUIT
+35 ;---> WVPPAP=IEN OF PREVIOUS PAP IN WV PROCEDURE FILE 790.1.
+36 SET WVPPAP=+Y
End DoDot:1
if WVPOP
QUIT
+37 ;
+38 ;---> ASK DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
+39 DO DATECHK
if WVPOP
QUIT
+40 DO NEW2(WVDFN,WVPCDN,WVPCDT,"",WVPPAP,.DA,.WVERROR)
+41 QUIT
+42 ;
NEW2(DFN,PCDIEN,DATE,DRSTRG,PREVPAP,DA,ERROR) ;EP
+1 ;---> ADD A NEW PROCEDURE.
+2 ;---> PATIENT AND PROCEDURE ALREADY SELECTED.
+3 ;---> NOW GENERATE ACCESSION# FOR WV PROCEDURE FILE ENTRY.
+4 ;---> REQUIRED VARIABLES: DFN=IEN IN WV PATIENT FILE
+5 ;---> PCDIEN=IEN OF PROCEDURE TYPE (#790.2).
+6 ;
+7 SET X=$$ACCSSN^WVUTL5(PCDIEN)
NEW DIC
+8 IF X']""
Begin DoDot:1
+9 SET ERROR=-1
+10 ;quit if a background (tasked) job
if $DATA(ZTQUEUED)
QUIT
+11 WRITE !!?5,*7,"UNABLE TO GENERATE ACCESSION#. CONTACT YOUR SITE MANAGER."
+12 DO DIRZ^WVUTL3
+13 QUIT
End DoDot:1
QUIT
+14 ;
+15 IF $GET(DRSTRG)']""
Begin DoDot:1
+16 ;---> DEFAULTS: DATE OF PROCEDURE IS TODAY, STATUS IS OPEN.
+17 SET DRSTRG=".02////"_DFN_";.04////"_PCDIEN
+18 SET DRSTRG=DRSTRG_";.09///"_$SELECT($DATA(WVLFRT):WVLFRT,1:"")_";.12///"_DATE
+19 SET DRSTRG=DRSTRG_";.14///o"
+20 SET DRSTRG=DRSTRG_";.18////"_DUZ_";.19///T;.3////"_$GET(PREVPAP)
+21 SET DRSTRG=DRSTRG_";.34////"_$GET(DUZ(2))
End DoDot:1
+22 ;
+23 DO FILE^WVFMAN(790.1,DRSTRG,"ML",X,790,.Y)
+24 ;---> IF Y<0, CHECK PERMISSIONS.
+25 IF Y<0
Begin DoDot:1
+26 SET ERROR=Y
+27 ;quit if a background (tasked) job
if $DATA(ZTQUEUED)
QUIT
+28 WRITE !?5,*7,"UNABLE TO CREATE NEW PROCEDURE."
+29 DO DIRZ^WVUTL3
SET WVPOP=1
+30 QUIT
End DoDot:1
QUIT
+31 SET DA=+Y
+32 QUIT
+33 ;
+34 ;
EDIT ;EP
+1 ;---> CALLED BY OPTION: "WV EDIT PROCEDURE".
+2 ;---> EDIT AN EXISTING PROCEDURE.
+3 DO TITLE^WVUTL5("EDIT A PROCEDURE")
+4 DO LKUPPCD(.Y)
+5 if Y<0
QUIT
LT ; Called from WVLABADD routine to immediately edit a procedure created
+1 ; from a lab test.
+2 ;---> DA=IEN OF PROCEDURE IN PROCEDURE FILE 790.1.
+3 SET DA=+Y
+4 IF $PIECE($GET(^WV(790.1,+DA,0)),U,15)]""
DO ^WVRADWP
+5 IF $PIECE($GET(^WV(790.1,+DA,2)),U,17)]""
Begin DoDot:1
+6 DO ^WVLABWP
+7 if '$DATA(^TMP("WVLAB",$JOB))
QUIT
+8 SET WVLOOP=0
+9 FOR
SET WVLOOP=$ORDER(^TMP("WVLAB",$JOB,WVLOOP))
if WVLOOP'>0
QUIT
Begin DoDot:2
+10 SET ^WV(790.1,DA,9,WVLOOP,0)=$GET(^TMP("WVLAB",$JOB,WVLOOP,0))
SET WVLOOP(1)=WVLOOP
+11 QUIT
End DoDot:2
+12 SET ^WV(790.1,DA,9,0)="^^"_$GET(WVLOOP(1))_"^"_$GET(WVLOOP(1))
+13 KILL ^TMP("WVLAB",$JOB)
+14 QUIT
End DoDot:1
+15 DO EDIT2^WVPROC1(DA,.WVPOP)
if WVPOP!($DATA(WVNOFOL))
QUIT
+16 DO EX^WVRADWP
+17 DO PCDVARS^WVUTL3(DA,1)
+18 DO NORMAL^WVPROC1
+19 DO EXIT
+20 QUIT
+21 ;
+22 ;
HISTORIC ;EP
+1 ;---> CALLED BY OPTION: "WV ADD AN HISTORICAL PROCEDURE".
+2 ;---> ADD HISTORICAL PROCEDURES (NO PROVIDER, WARD/CLINIC, FACILITY).
+3 DO SETVARS^WVUTL5
SET WVPOP1=0
NEW DA,DIE,Y
+4 FOR
Begin DoDot:1
+5 DO TITLE^WVUTL5("ENTER HISTORICAL DATA")
+6 DO NEWNT
WRITE !
+7 if (WVPOP!('$GET(DA)))
QUIT
+8 SET WVPN=$PIECE(^WV(790.1,DA,0),U,4)
+9 SET DR=".05;.08;.1;.14////c"
+10 DO DIE^WVFMAN(790.1,DR,DA,.WVPOP)
End DoDot:1
if WVPOP1
QUIT
+11 DO EXIT
+12 QUIT
+13 ;
+14 ;
LABEDIT ;EP
+1 ;---> CALLED BY OPTION: "WV LAB EDIT PROCEDURE".
+2 SET WVNOFOL=1
DO EDIT
DO EXIT
+3 QUIT
+4 ;
+5 ;
RADMOD(DA) ;EP
+1 ;---> MODIFY A PROCEDURE THAT WAS IMPORTED FROM RADIOLOGY AND
+2 ;---> HAS BEEN CHANGED.
+3 ;---> DA=IEN OF PROCEDURE IN WV PROCEDURE FILE #790.1.
+4 if '$GET(DA)
QUIT
+5 SET DR=".13////"_DT_";.14////o"
+6 DO DIE^WVFMAN(790.1,DR,DA,.WVPOP)
+7 QUIT
+8 ;
+9 ;
LKUPPCD(Y) ;EP
+1 ;---> LOOKUP A PROCEDURE.
+2 NEW A
+3 DO SETVARS^WVUTL5
+4 SET A="Select ACCESSION# or PATIENT NAME: "
+5 DO DIC^WVFMAN(790.1,"QEMA",.Y,A,"","","",.WVPOP)
+6 QUIT
+7 ;
DATECHK ;EP
+1 ;---> PROMPT FOR DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
+2 NEW WVNEW,DIR,DIRUT,N,Y
SET WVPOP=0
+3 SET DIR("?",1)=" Enter the date on which this procedure was performed:"
+4 SET DIR("?")=" (NOTE: Dates in the future may NOT be entered.)"
+5 SET DIR(0)="DA^0:DT:EX"
SET DIR("A")=" Select DATE: "
SET DIR("B")="TODAY"
+6 DO ^DIR
KILL DIR
+7 IF Y<1
SET WVPOP=1
QUIT
+8 SET WVPCDT=Y
DO DD^%DT
WRITE " ",Y
+9 SET N=0
SET WVNEW=0
+10 FOR
SET N=$ORDER(^WV(790.1,"C",WVDFN,N))
if ('N)!(WVPOP)!(WVNEW)
QUIT
Begin DoDot:1
+11 SET Y=^WV(790.1,N,0)
+12 ;---> QUIT IF NOT THE SAME PROCEDURE TYPE.
+13 if $PIECE(Y,U,4)'=WVPCDN
QUIT
+14 ;---> QUIT IF NOT THE SAME PROCEDURE DATE.
+15 if $PIECE(Y,U,12)'=WVPCDT
QUIT
+16 ;---> QUIT IF THIS PROCEDURE HAS A RESULT/DIAG OF "ERROR/DISREGARD".
+17 if $PIECE(Y,U,5)=8
QUIT
+18 NEW WVPN
SET WVPN=$PIECE(^WV(790.2,$PIECE(Y,U,4),0),U)
+19 WRITE !!?5,"A ",WVPN," already exists for this patient on this date,"
+20 WRITE !?5,"with an Accession# of ",$PIECE(Y,U)
+21 WRITE ". You may edit that procedure by"
+22 WRITE !?5,"calling up ",$PIECE(Y,U)," under the ""Edit a Procedure"" option."
+23 WRITE !?5,"Or you may enter another ",WVPN," for this patient"
+24 WRITE !?5,"on this date."
+25 WRITE !!?5,"Do you REALLY want to add another ",WVPN," for this patient"
+26 WRITE !?5,"on this date?"
+27 SET DIR("?")=" Enter NO to avoid adding another "_WVPN
+28 SET DIR("?")=DIR("?")_" on this date."
+29 SET DIR(0)="Y"
SET DIR("A")=" Enter Yes or No"
SET DIR("B")="NO"
+30 DO ^DIR
KILL DIR
+31 IF $DATA(DIRUT)!('Y)
SET WVPOP=1
QUIT
+32 SET WVNEW=1
End DoDot:1
+33 QUIT
+34 ;
ERROR1 ;EP
+1 WRITE !!?10,*7,"NEW PROCEDURE ENTRY FOR THIS PATIENT FAILED."
+2 QUIT
