DGRPD1 ;BPFO/JRC/BAJ - PATIENT INQUIRY (NEW) ; 8/15/08 11:35am
;;5.3;PIMS;**703,730,1015,1016**;JUN 30, 2012;Build 20
; DG*5.3*688 BAJ
; tags HDR & OKLINE moved as is from DGRPD for size considerations
Q
EC ;display emergency contact information
N DGEC1,DGEC2
Q:'$G(DFN)
S VAOA("A")=1,VAROOT="DGEC1" D OAD^VADPT ; Get Primary EC
S VAOA("A")=4,VAROOT="DGEC2" D OAD^VADPT ; Get Secondary EC
I DGEC1(9)]"" D
. W !,"Emergency Contact Information:"
. ;Contacts name and realtionship
. W !?5,"E-Cont.: ",DGEC1(9)
. I DGEC2(9)]"" W ?40,"E2-Cont.: ",DGEC2(9)
. W !,"Relationship: ",DGEC1(10)
. I DGEC2(9)]"" W ?36,"Relationship: ",DGEC2(10)
. ;ECs address lines 1, 2 and 3
. I DGEC1(1)]"" W !?14,DGEC1(1)
. I DGEC1(1)']"",DGEC2(1)]"" W !
. I DGEC2(1)]"" W ?50,DGEC2(1)
. I DGEC1(2)]"" W !?14,DGEC1(2)
. I DGEC1(2)']"",DGEC2(2)]"" W !
. I DGEC2(2)]"" W ?50,DGEC2(2)
. I DGEC1(3)]"" W !?14,DGEC1(3)
. I DGEC1(3)']"",DGEC2(3)]"" W !
. I DGEC2(3)]"" W ?50,DGEC2(3)
. ;Emergency Contact 1 City, State an Zip+4
. I DGEC1(4)]"" D
. . W !?14,DGEC1(4)
. . I DGEC1(5)]"" W ", "_$$GET1^DIQ(5,+DGEC1(5),1)
. . W " ",$P(DGEC1(11),"^",2)
. ;Emergency Contact 2 City State and Zip+4
. I DGEC2(4)]"" D
. . I DGEC1(4)']"" W !
. . W ?50,DGEC2(4)
. . I DGEC2(5)]"" W ", "_$$GET1^DIQ(5,+DGEC2(5),1)
. . W " ",$P(DGEC2(11),"^",2)
.;Home and work phones
. W !,?7,"Phone: ",$S(DGEC1(8)]"":DGEC1(8),1:"UNSPECIFIED")
. I DGEC2(9)]"" W ?43,"Phone: ",$S(DGEC2(8)]"":DGEC2(8),1:"UNSPECIFIED")
. W !?2,"Work Phone: ",$S($P(^DPT(DFN,.33),U,11)]"":$P(^DPT(DFN,.33),U,11),1:"UNSPECIFIED")
. I DGEC2(9)]"" W ?38,"Work Phone: ",$S($P(^DPT(DFN,.331),U,11)]"":$P(^DPT(DFN,.331),U,11),1:"UNSPECIFIED")
D KVAR^VADPT
Q
;
CATDIS ;
;displays catastrophic disabity review date if there is one
N DGCDIS
Q:'$G(DFN)
I $$GET^DGENCDA(DFN,.DGCDIS) D
.Q:'DGCDIS("REVDTE")
.W !!,"Catastrophically Disabled Review Date: ",$$FMTE^XLFDT(DGCDIS("REVDTE"),1)
Q
HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
;MPI/PD CHANGE
W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
;END MPI/PD CHANGE
OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE
;
;IN: DGLINE --MAX LINE COUNT W/O PAUSE
;OUT: DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW
; DGRPOUT[SET] -- 1 IF "
N X,Y ;**286** MLR 09/25/00 Newing X & Y variables prior to ^DIR
I $G(IOST)["P-" Q DGLINE ; if printer, quit
I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0
Q DGLINE
;
DGRPD1 ;BPFO/JRC/BAJ - PATIENT INQUIRY (NEW) ; 8/15/08 11:35am
+1 ;;5.3;PIMS;**703,730,1015,1016**;JUN 30, 2012;Build 20
+2 ; DG*5.3*688 BAJ
+3 ; tags HDR & OKLINE moved as is from DGRPD for size considerations
+4 QUIT
EC ;display emergency contact information
+1 NEW DGEC1,DGEC2
+2 IF '$GET(DFN)
QUIT
+3 ; Get Primary EC
SET VAOA("A")=1
SET VAROOT="DGEC1"
DO OAD^VADPT
+4 ; Get Secondary EC
SET VAOA("A")=4
SET VAROOT="DGEC2"
DO OAD^VADPT
+5 IF DGEC1(9)]""
Begin DoDot:1
+6 WRITE !,"Emergency Contact Information:"
+7 ;Contacts name and realtionship
+8 WRITE !?5,"E-Cont.: ",DGEC1(9)
+9 IF DGEC2(9)]""
WRITE ?40,"E2-Cont.: ",DGEC2(9)
+10 WRITE !,"Relationship: ",DGEC1(10)
+11 IF DGEC2(9)]""
WRITE ?36,"Relationship: ",DGEC2(10)
+12 ;ECs address lines 1, 2 and 3
+13 IF DGEC1(1)]""
WRITE !?14,DGEC1(1)
+14 IF DGEC1(1)']""
IF DGEC2(1)]""
WRITE !
+15 IF DGEC2(1)]""
WRITE ?50,DGEC2(1)
+16 IF DGEC1(2)]""
WRITE !?14,DGEC1(2)
+17 IF DGEC1(2)']""
IF DGEC2(2)]""
WRITE !
+18 IF DGEC2(2)]""
WRITE ?50,DGEC2(2)
+19 IF DGEC1(3)]""
WRITE !?14,DGEC1(3)
+20 IF DGEC1(3)']""
IF DGEC2(3)]""
WRITE !
+21 IF DGEC2(3)]""
WRITE ?50,DGEC2(3)
+22 ;Emergency Contact 1 City, State an Zip+4
+23 IF DGEC1(4)]""
Begin DoDot:2
+24 WRITE !?14,DGEC1(4)
+25 IF DGEC1(5)]""
WRITE ", "_$$GET1^DIQ(5,+DGEC1(5),1)
+26 WRITE " ",$PIECE(DGEC1(11),"^",2)
End DoDot:2
+27 ;Emergency Contact 2 City State and Zip+4
+28 IF DGEC2(4)]""
Begin DoDot:2
+29 IF DGEC1(4)']""
WRITE !
+30 WRITE ?50,DGEC2(4)
+31 IF DGEC2(5)]""
WRITE ", "_$$GET1^DIQ(5,+DGEC2(5),1)
+32 WRITE " ",$PIECE(DGEC2(11),"^",2)
End DoDot:2
+33 ;Home and work phones
+34 WRITE !,?7,"Phone: ",$SELECT(DGEC1(8)]"":DGEC1(8),1:"UNSPECIFIED")
+35 IF DGEC2(9)]""
WRITE ?43,"Phone: ",$SELECT(DGEC2(8)]"":DGEC2(8),1:"UNSPECIFIED")
+36 WRITE !?2,"Work Phone: ",$SELECT($PIECE(^DPT(DFN,.33),U,11)]"":$PIECE(^DPT(DFN,.33),U,11),1:"UNSPECIFIED")
+37 IF DGEC2(9)]""
WRITE ?38,"Work Phone: ",$SELECT($PIECE(^DPT(DFN,.331),U,11)]"":$PIECE(^DPT(DFN,.331),U,11),1:"UNSPECIFIED")
End DoDot:1
+38 DO KVAR^VADPT
+39 QUIT
+40 ;
CATDIS ;
+1 ;displays catastrophic disabity review date if there is one
+2 NEW DGCDIS
+3 IF '$GET(DFN)
QUIT
+4 IF $$GET^DGENCDA(DFN,.DGCDIS)
Begin DoDot:1
+5 IF 'DGCDIS("REVDTE")
QUIT
+6 WRITE !!,"Catastrophically Disabled Review Date: ",$$FMTE^XLFDT(DGCDIS("REVDTE"),1)
End DoDot:1
+7 QUIT
HDR IF '$DATA(IOF)
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+1 ;MPI/PD CHANGE
+2 WRITE @IOF,!,$PIECE(VADM(1),"^",1),?40,$PIECE(VADM(2),"^",2),?65,$PIECE(VADM(3),"^",2)
SET X=""
SET $PIECE(X,"=",78)=""
WRITE !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,!
QUIT
+3 ;END MPI/PD CHANGE
OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE
+1 ;
+2 ;IN: DGLINE --MAX LINE COUNT W/O PAUSE
+3 ;OUT: DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW
+4 ; DGRPOUT[SET] -- 1 IF "
+5 ;**286** MLR 09/25/00 Newing X & Y variables prior to ^DIR
NEW X,Y
+6 ; if printer, quit
IF $GET(IOST)["P-"
QUIT DGLINE
+7 IF $Y>DGLINE
NEW DIR
SET DIR(0)="E"
DO ^DIR
IF Y
DO HDR
IF 'Y
SET DGRPOUT=1
SET DGLINE=0
+8 QUIT DGLINE
+9 ;
