DGENPT ;ALB/CJM,LBD - Patient Protocols; 13 JUN 1997 ; 3/29/11 11:59am
;;5.3;Registration;**121,147,838**;08/13/93;Build 5
;
PF ;Entry point for DGENPT PREFERRED FACILITY protocol
; Input -- DFN Patient IEN
; Output -- VALMBCK R =Refresh screen
S VALMBCK=""
D FULL^VALM1
D PREFER(DFN)
D HDR^DGENL
D MESSAGE^DGENL(DFN)
S VALMBCK="R"
Q
;
PREFER(DFN) ;
;Description: Enter/Edit patient's preferred facility.
;Input: DFN - patient ien
;Output: none
;
Q:'$G(DFN)
Q:'$D(^DPT(DFN,0))
;
N PREFAC,RESPONSE,PFSRC
;If SOURCE DESIGNATION field (#27.03) = 'E' or 'PA' then PREFERRED
;FACILITY cannot be edited. Display message and quit. (DG*5.3*838)
S PFSRC=$P($G(^DPT(DFN,"ENR")),"^",3)
I PFSRC="E"!(PFSRC="PA") D Q
.W !!,"Preferred Facility can only be edited/modified by an ESR user."
.W !,"Please contact HEC to request changes/edits."
.N DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR
;
S PREFAC=$$PREF^DGENPTA(DFN)
S:'PREFAC PREFAC=$P($$SITE^VASITE(),"^")
W !
PRMPT I $$PROMPT^DGENU(2,27.02,PREFAC,.RESPONSE)
I $G(RESPONSE)'="",$$STOREPRE^DGENPTA1(DFN,RESPONSE) Q
I $P($G(^DPT(DFN,"ENR")),"^",2)="" W !,"Entry of a Preferred Facility is required!" G PRMPT
I $G(X)="@" D
.W !,"The Preferred Facility cannot be deleted!"
.N DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENPT 1386 printed Oct 16, 2024@18:43:32 Page 2
DGENPT ;ALB/CJM,LBD - Patient Protocols; 13 JUN 1997 ; 3/29/11 11:59am
+1 ;;5.3;Registration;**121,147,838**;08/13/93;Build 5
+2 ;
PF ;Entry point for DGENPT PREFERRED FACILITY protocol
+1 ; Input -- DFN Patient IEN
+2 ; Output -- VALMBCK R =Refresh screen
+3 SET VALMBCK=""
+4 DO FULL^VALM1
+5 DO PREFER(DFN)
+6 DO HDR^DGENL
+7 DO MESSAGE^DGENL(DFN)
+8 SET VALMBCK="R"
+9 QUIT
+10 ;
PREFER(DFN) ;
+1 ;Description: Enter/Edit patient's preferred facility.
+2 ;Input: DFN - patient ien
+3 ;Output: none
+4 ;
+5 if '$GET(DFN)
QUIT
+6 if '$DATA(^DPT(DFN,0))
QUIT
+7 ;
+8 NEW PREFAC,RESPONSE,PFSRC
+9 ;If SOURCE DESIGNATION field (#27.03) = 'E' or 'PA' then PREFERRED
+10 ;FACILITY cannot be edited. Display message and quit. (DG*5.3*838)
+11 SET PFSRC=$PIECE($GET(^DPT(DFN,"ENR")),"^",3)
+12 IF PFSRC="E"!(PFSRC="PA")
Begin DoDot:1
+13 WRITE !!,"Preferred Facility can only be edited/modified by an ESR user."
+14 WRITE !,"Please contact HEC to request changes/edits."
+15 NEW DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
WRITE !
DO ^DIR
End DoDot:1
QUIT
+16 ;
+17 SET PREFAC=$$PREF^DGENPTA(DFN)
+18 if 'PREFAC
SET PREFAC=$PIECE($$SITE^VASITE(),"^")
+19 WRITE !
PRMPT IF $$PROMPT^DGENU(2,27.02,PREFAC,.RESPONSE)
+1 IF $GET(RESPONSE)'=""
IF $$STOREPRE^DGENPTA1(DFN,RESPONSE)
QUIT
+2 IF $PIECE($GET(^DPT(DFN,"ENR")),"^",2)=""
WRITE !,"Entry of a Preferred Facility is required!"
GOTO PRMPT
+3 IF $GET(X)="@"
Begin DoDot:1
+4 WRITE !,"The Preferred Facility cannot be deleted!"
+5 NEW DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
WRITE !
DO ^DIR
End DoDot:1
+6 QUIT
