DGENPT.m

DGENPT ;ALB/CJM,LBD - Patient Protocols; 13 JUN 1997 ; 3/29/11 11:59am

 ;;5.3;PIMS;**121,147,1015,1016**;JUN 30, 2012;Build 20

 ;

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

DGENPT    ;ALB/CJM,LBD - Patient Protocols; 13 JUN 1997 ; 3/29/11 11:59am

 +1       ;;5.3;PIMS;**121,147,1015,1016**;JUN 30, 2012;Build 20

 +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