- 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 Feb 19, 2025@00:13:52 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