- DGRPD1 ;BPFO/JRC,BAJ,DJE,ARF,JAM,ARF - PATIENT INQUIRY (NEW) ;Sep 28, 2017 5:35PM
- ;;5.3;Registration;**703,730,688,863,935,985,997,1067**;Aug 13, 1993;Build 23
- ; 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
- ; DG*5.3*997;jam; new variables for displaying foreign addresses
- N DGCNTRY1,DGCNTRY2,DGFOR1,DGFOR2
- 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 !?6,"E-Cont.: ",DGEC1(9)
- . I DGEC2(9)]"" W ?46,"E2-Cont.: ",DGEC2(9)
- . ;DG*5.3*1067 begin - Added RELATION TYPE field and moved
- . ;RELATIONSHIP TO PATIENT under the RELATION TYPE.
- . ;Changed its label to from RELATIONSHIP TO PATIENT to RELATION NOTE
- . W:((DGEC1(12)'="")!(DGEC2(12)'="")!(DGEC1(10)'="")!(DGEC2(10)'="")) ! ;RELATION TYPE is in node 10-RELATIONSHIP TO PATIENT is in node 12
- . W:DGEC1(10)]'"" "Relation Type: ",$E(DGEC1(10),1,25)
- . W:DGEC2(10)]'"" ?41,"Relation Type: ",DGEC2(10)
- . W:((DGEC1(12)'="")!(DGEC2(12)'="")) !
- . I DGEC1(10)]"" W "Relation Note: ",DGEC1(12)
- . I DGEC2(10)]"" W ?41,"Relation Note: ",DGEC2(12)
- . ;DG*5.3*1067 end
- . ;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)
- . ; DG*5.3*997;jam; allow for Foreign addresses
- . ; - get the EC Countries and flags for foreign address
- . S DGCNTRY1=$$GET1^DIQ(2,DFN_",",.3306,"I")
- . S DGCNTRY2=$$GET1^DIQ(2,DFN_",",.331012,"I")
- . S DGFOR1=$$FORIEN^DGADDUTL(DGCNTRY1) I DGFOR1=-1 S DGFOR1=1
- . S DGFOR2=$$FORIEN^DGADDUTL(DGCNTRY2) I DGFOR2=-1 S DGFOR2=1
- . S DGCNTRY1=$$CNTRYI^DGADDUTL(DGCNTRY1)
- . S DGCNTRY2=$$CNTRYI^DGADDUTL(DGCNTRY2)
- . ;Emergency Contact 1 City, State an Zip+4
- . I DGEC1(4)]"" D
- . . W !?14,DGEC1(4)
- . . ; DG*5.3*997;jam; check for EC1 foreign address. If foreign, Province and Postal Code follow the city
- . . I 'DGFOR1 D
- . . . I DGEC1(5)]"" W ", "_$$GET1^DIQ(5,+DGEC1(5),1)
- . . . W " ",$P(DGEC1(11),"^",2)
- . . I DGFOR1 D
- . . . W " "_$$GET1^DIQ(2,DFN_",",.3307)_" "_$$GET1^DIQ(2,DFN_",",.3308)
- . ;Emergency Contact 2 City State and Zip+4
- . I DGEC2(4)]"" D
- . . I DGEC1(4)']"" W !
- . . W ?50,DGEC2(4)
- . . ; DG*5.3*997;jam; check for EC2 foreign address. If foreign, Province and Postal Code follow the city
- . . I 'DGFOR2 D
- . . . I DGEC2(5)]"" W ", "_$$GET1^DIQ(5,+DGEC2(5),1)
- . . . W " ",$P(DGEC2(11),"^",2)
- . . I DGFOR2 D
- . . . W " "_$$GET1^DIQ(2,DFN_",",.331013)_" "_$$GET1^DIQ(2,DFN_",",.331014)
- . ; DG*5.3*997;jam; ECs Country
- . I DGCNTRY1]"" W !?14,$E(DGCNTRY1,1,30)
- . I DGCNTRY1']"" W !
- . W ?50,$E(DGCNTRY2,1,30)
- . ;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
- ;DJE DG*5.3*935 - Add Member ID To Vista Registration Banner - RM#879322 (added SSNNM call)
- ;ARF DG*5.3*985 - Add Preferred Name to Patient Inquiry banner
- N X,DGLN,DGSSNNM,DGSSNNM1,DGPRFNAM,DGSSN,DGEPI,DGNAME,DGDOB,DGCNT,DGLINE,DIWL,DIWR,DIWF
- ;W @IOF,!,$$SSNNM^DGRPU(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,! Q ;**863 - MVI_2351 (ptd)
- ;END MPI/PD CHANGE
- ;ARF DG*5.3*985 - replace previous code for the banner with logic to pull out individual fields to place them in proper order
- S DGPRFNAM=$$GET1^DIQ(2,+DFN_",",.2405,"E")
- S:DGPRFNAM'="" DGPRFNAM="("_DGPRFNAM_")"
- S DGSSNNM=$$SSNNM^DGRPU(DFN)
- S DGNAME=$P(DGSSNNM,";",1)_";"
- S DGSSNNM1=$P(DGSSNNM,";",2)
- S DGSSN=$P(DGSSNNM1," ",3)
- S DGEPI=$S($P(DGSSNNM1," ",2)'="":" "_$P(DGSSNNM1," ",2),1:"")
- S DGDOB=$P(VADM(3),"^",2)
- S DGDOB=$TR(DGDOB," ","_") ;replaced space in DGDOB with "_" for the ^DIWP utility
- ;ARF DG*5.3*985 - create the string of fields for the banner
- S X=DGNAME_DGPRFNAM_DGEPI_" "_DGSSN_" "_DGDOB
- W @IOF,!
- ;ARF DG*5.3*985 - use ^DIWP to insure proper wrapping if string goes beyond 80 chars
- K ^UTILITY($J,"W") S DIWL=0,DIWR=79,DIWF="" D ^DIWP
- S DGCNT=^UTILITY($J,"W",0)
- F DGLN=1:1:DGCNT S DGLINE=$TR(^UTILITY($J,"W",0,DGLN,0),"_"," ") W !,DGLINE ;replaced "_" for display
- S X="",$P(X,"=",78)="" W !,X,!
- K ^UTILITY($J,"W")
- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPD1 5470 printed Feb 19, 2025@00:22:12 Page 2
- DGRPD1 ;BPFO/JRC,BAJ,DJE,ARF,JAM,ARF - PATIENT INQUIRY (NEW) ;Sep 28, 2017 5:35PM
- +1 ;;5.3;Registration;**703,730,688,863,935,985,997,1067**;Aug 13, 1993;Build 23
- +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 ; DG*5.3*997;jam; new variables for displaying foreign addresses
- +3 NEW DGCNTRY1,DGCNTRY2,DGFOR1,DGFOR2
- +4 if '$GET(DFN)
- QUIT
- +5 ; Get Primary EC
- SET VAOA("A")=1
- SET VAROOT="DGEC1"
- DO OAD^VADPT
- +6 ; Get Secondary EC
- SET VAOA("A")=4
- SET VAROOT="DGEC2"
- DO OAD^VADPT
- +7 IF DGEC1(9)]""
- Begin DoDot:1
- +8 WRITE !,"Emergency Contact Information:"
- +9 ;Contacts name and realtionship
- +10 WRITE !?6,"E-Cont.: ",DGEC1(9)
- +11 IF DGEC2(9)]""
- WRITE ?46,"E2-Cont.: ",DGEC2(9)
- +12 ;DG*5.3*1067 begin - Added RELATION TYPE field and moved
- +13 ;RELATIONSHIP TO PATIENT under the RELATION TYPE.
- +14 ;Changed its label to from RELATIONSHIP TO PATIENT to RELATION NOTE
- +15 ;RELATION TYPE is in node 10-RELATIONSHIP TO PATIENT is in node 12
- if ((DGEC1(12)'="")!(DGEC2(12)'="")!(DGEC1(10)'="")!(DGEC2(10)'=""))
- WRITE !
- +16 if DGEC1(10)]'""
- WRITE "Relation Type: ",$EXTRACT(DGEC1(10),1,25)
- +17 if DGEC2(10)]'""
- WRITE ?41,"Relation Type: ",DGEC2(10)
- +18 if ((DGEC1(12)'="")!(DGEC2(12)'=""))
- WRITE !
- +19 IF DGEC1(10)]""
- WRITE "Relation Note: ",DGEC1(12)
- +20 IF DGEC2(10)]""
- WRITE ?41,"Relation Note: ",DGEC2(12)
- +21 ;DG*5.3*1067 end
- +22 ;ECs address lines 1, 2 and 3
- +23 IF DGEC1(1)]""
- WRITE !?14,DGEC1(1)
- +24 IF DGEC1(1)']""
- IF DGEC2(1)]""
- WRITE !
- +25 IF DGEC2(1)]""
- WRITE ?50,DGEC2(1)
- +26 IF DGEC1(2)]""
- WRITE !?14,DGEC1(2)
- +27 IF DGEC1(2)']""
- IF DGEC2(2)]""
- WRITE !
- +28 IF DGEC2(2)]""
- WRITE ?50,DGEC2(2)
- +29 IF DGEC1(3)]""
- WRITE !?14,DGEC1(3)
- +30 IF DGEC1(3)']""
- IF DGEC2(3)]""
- WRITE !
- +31 IF DGEC2(3)]""
- WRITE ?50,DGEC2(3)
- +32 ; DG*5.3*997;jam; allow for Foreign addresses
- +33 ; - get the EC Countries and flags for foreign address
- +34 SET DGCNTRY1=$$GET1^DIQ(2,DFN_",",.3306,"I")
- +35 SET DGCNTRY2=$$GET1^DIQ(2,DFN_",",.331012,"I")
- +36 SET DGFOR1=$$FORIEN^DGADDUTL(DGCNTRY1)
- IF DGFOR1=-1
- SET DGFOR1=1
- +37 SET DGFOR2=$$FORIEN^DGADDUTL(DGCNTRY2)
- IF DGFOR2=-1
- SET DGFOR2=1
- +38 SET DGCNTRY1=$$CNTRYI^DGADDUTL(DGCNTRY1)
- +39 SET DGCNTRY2=$$CNTRYI^DGADDUTL(DGCNTRY2)
- +40 ;Emergency Contact 1 City, State an Zip+4
- +41 IF DGEC1(4)]""
- Begin DoDot:2
- +42 WRITE !?14,DGEC1(4)
- +43 ; DG*5.3*997;jam; check for EC1 foreign address. If foreign, Province and Postal Code follow the city
- +44 IF 'DGFOR1
- Begin DoDot:3
- +45 IF DGEC1(5)]""
- WRITE ", "_$$GET1^DIQ(5,+DGEC1(5),1)
- +46 WRITE " ",$PIECE(DGEC1(11),"^",2)
- End DoDot:3
- +47 IF DGFOR1
- Begin DoDot:3
- +48 WRITE " "_$$GET1^DIQ(2,DFN_",",.3307)_" "_$$GET1^DIQ(2,DFN_",",.3308)
- End DoDot:3
- End DoDot:2
- +49 ;Emergency Contact 2 City State and Zip+4
- +50 IF DGEC2(4)]""
- Begin DoDot:2
- +51 IF DGEC1(4)']""
- WRITE !
- +52 WRITE ?50,DGEC2(4)
- +53 ; DG*5.3*997;jam; check for EC2 foreign address. If foreign, Province and Postal Code follow the city
- +54 IF 'DGFOR2
- Begin DoDot:3
- +55 IF DGEC2(5)]""
- WRITE ", "_$$GET1^DIQ(5,+DGEC2(5),1)
- +56 WRITE " ",$PIECE(DGEC2(11),"^",2)
- End DoDot:3
- +57 IF DGFOR2
- Begin DoDot:3
- +58 WRITE " "_$$GET1^DIQ(2,DFN_",",.331013)_" "_$$GET1^DIQ(2,DFN_",",.331014)
- End DoDot:3
- End DoDot:2
- +59 ; DG*5.3*997;jam; ECs Country
- +60 IF DGCNTRY1]""
- WRITE !?14,$EXTRACT(DGCNTRY1,1,30)
- +61 IF DGCNTRY1']""
- WRITE !
- +62 WRITE ?50,$EXTRACT(DGCNTRY2,1,30)
- +63 ;Home and work phones
- +64 WRITE !,?7,"Phone: ",$SELECT(DGEC1(8)]"":DGEC1(8),1:"UNSPECIFIED")
- +65 IF DGEC2(9)]""
- WRITE ?43,"Phone: ",$SELECT(DGEC2(8)]"":DGEC2(8),1:"UNSPECIFIED")
- +66 WRITE !?2,"Work Phone: ",$SELECT($PIECE(^DPT(DFN,.33),U,11)]"":$PIECE(^DPT(DFN,.33),U,11),1:"UNSPECIFIED")
- +67 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
- +68 DO KVAR^VADPT
- +69 QUIT
- +70 ;
- 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 ;DJE DG*5.3*935 - Add Member ID To Vista Registration Banner - RM#879322 (added SSNNM call)
- +3 ;ARF DG*5.3*985 - Add Preferred Name to Patient Inquiry banner
- +4 NEW X,DGLN,DGSSNNM,DGSSNNM1,DGPRFNAM,DGSSN,DGEPI,DGNAME,DGDOB,DGCNT,DGLINE,DIWL,DIWR,DIWF
- +5 ;W @IOF,!,$$SSNNM^DGRPU(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,! Q ;**863 - MVI_2351 (ptd)
- +6 ;END MPI/PD CHANGE
- +7 ;ARF DG*5.3*985 - replace previous code for the banner with logic to pull out individual fields to place them in proper order
- +8 SET DGPRFNAM=$$GET1^DIQ(2,+DFN_",",.2405,"E")
- +9 if DGPRFNAM'=""
- SET DGPRFNAM="("_DGPRFNAM_")"
- +10 SET DGSSNNM=$$SSNNM^DGRPU(DFN)
- +11 SET DGNAME=$PIECE(DGSSNNM,";",1)_";"
- +12 SET DGSSNNM1=$PIECE(DGSSNNM,";",2)
- +13 SET DGSSN=$PIECE(DGSSNNM1," ",3)
- +14 SET DGEPI=$SELECT($PIECE(DGSSNNM1," ",2)'="":" "_$PIECE(DGSSNNM1," ",2),1:"")
- +15 SET DGDOB=$PIECE(VADM(3),"^",2)
- +16 ;replaced space in DGDOB with "_" for the ^DIWP utility
- SET DGDOB=$TRANSLATE(DGDOB," ","_")
- +17 ;ARF DG*5.3*985 - create the string of fields for the banner
- +18 SET X=DGNAME_DGPRFNAM_DGEPI_" "_DGSSN_" "_DGDOB
- +19 WRITE @IOF,!
- +20 ;ARF DG*5.3*985 - use ^DIWP to insure proper wrapping if string goes beyond 80 chars
- +21 KILL ^UTILITY($JOB,"W")
- SET DIWL=0
- SET DIWR=79
- SET DIWF=""
- DO ^DIWP
- +22 SET DGCNT=^UTILITY($JOB,"W",0)
- +23 ;replaced "_" for display
- FOR DGLN=1:1:DGCNT
- SET DGLINE=$TRANSLATE(^UTILITY($JOB,"W",0,DGLN,0),"_"," ")
- WRITE !,DGLINE
- +24 SET X=""
- SET $PIECE(X,"=",78)=""
- WRITE !,X,!
- +25 KILL ^UTILITY($JOB,"W")
- 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 ;