Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGRPD1

DGRPD1.m

Go to the documentation of this file.
  1. 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
  1. ; DG*5.3*688 BAJ
  1. ; tags HDR & OKLINE moved as is from DGRPD for size considerations
  1. Q
  1. EC ;display emergency contact information
  1. N DGEC1,DGEC2
  1. ; DG*5.3*997;jam; new variables for displaying foreign addresses
  1. N DGCNTRY1,DGCNTRY2,DGFOR1,DGFOR2
  1. Q:'$G(DFN)
  1. S VAOA("A")=1,VAROOT="DGEC1" D OAD^VADPT ; Get Primary EC
  1. S VAOA("A")=4,VAROOT="DGEC2" D OAD^VADPT ; Get Secondary EC
  1. I DGEC1(9)]"" D
  1. . W !,"Emergency Contact Information:"
  1. . ;Contacts name and realtionship
  1. . W !?6,"E-Cont.: ",DGEC1(9)
  1. . I DGEC2(9)]"" W ?46,"E2-Cont.: ",DGEC2(9)
  1. . ;DG*5.3*1067 begin - Added RELATION TYPE field and moved
  1. . ;RELATIONSHIP TO PATIENT under the RELATION TYPE.
  1. . ;Changed its label to from RELATIONSHIP TO PATIENT to RELATION NOTE
  1. . W:((DGEC1(12)'="")!(DGEC2(12)'="")!(DGEC1(10)'="")!(DGEC2(10)'="")) ! ;RELATION TYPE is in node 10-RELATIONSHIP TO PATIENT is in node 12
  1. . W:DGEC1(10)]'"" "Relation Type: ",$E(DGEC1(10),1,25)
  1. . W:DGEC2(10)]'"" ?41,"Relation Type: ",DGEC2(10)
  1. . W:((DGEC1(12)'="")!(DGEC2(12)'="")) !
  1. . I DGEC1(10)]"" W "Relation Note: ",DGEC1(12)
  1. . I DGEC2(10)]"" W ?41,"Relation Note: ",DGEC2(12)
  1. . ;DG*5.3*1067 end
  1. . ;ECs address lines 1, 2 and 3
  1. . I DGEC1(1)]"" W !?14,DGEC1(1)
  1. . I DGEC1(1)']"",DGEC2(1)]"" W !
  1. . I DGEC2(1)]"" W ?50,DGEC2(1)
  1. . I DGEC1(2)]"" W !?14,DGEC1(2)
  1. . I DGEC1(2)']"",DGEC2(2)]"" W !
  1. . I DGEC2(2)]"" W ?50,DGEC2(2)
  1. . I DGEC1(3)]"" W !?14,DGEC1(3)
  1. . I DGEC1(3)']"",DGEC2(3)]"" W !
  1. . I DGEC2(3)]"" W ?50,DGEC2(3)
  1. . ; DG*5.3*997;jam; allow for Foreign addresses
  1. . ; - get the EC Countries and flags for foreign address
  1. . S DGCNTRY1=$$GET1^DIQ(2,DFN_",",.3306,"I")
  1. . S DGCNTRY2=$$GET1^DIQ(2,DFN_",",.331012,"I")
  1. . S DGFOR1=$$FORIEN^DGADDUTL(DGCNTRY1) I DGFOR1=-1 S DGFOR1=1
  1. . S DGFOR2=$$FORIEN^DGADDUTL(DGCNTRY2) I DGFOR2=-1 S DGFOR2=1
  1. . S DGCNTRY1=$$CNTRYI^DGADDUTL(DGCNTRY1)
  1. . S DGCNTRY2=$$CNTRYI^DGADDUTL(DGCNTRY2)
  1. . ;Emergency Contact 1 City, State an Zip+4
  1. . I DGEC1(4)]"" D
  1. . . W !?14,DGEC1(4)
  1. . . ; DG*5.3*997;jam; check for EC1 foreign address. If foreign, Province and Postal Code follow the city
  1. . . I 'DGFOR1 D
  1. . . . I DGEC1(5)]"" W ", "_$$GET1^DIQ(5,+DGEC1(5),1)
  1. . . . W " ",$P(DGEC1(11),"^",2)
  1. . . I DGFOR1 D
  1. . . . W " "_$$GET1^DIQ(2,DFN_",",.3307)_" "_$$GET1^DIQ(2,DFN_",",.3308)
  1. . ;Emergency Contact 2 City State and Zip+4
  1. . I DGEC2(4)]"" D
  1. . . I DGEC1(4)']"" W !
  1. . . W ?50,DGEC2(4)
  1. . . ; DG*5.3*997;jam; check for EC2 foreign address. If foreign, Province and Postal Code follow the city
  1. . . I 'DGFOR2 D
  1. . . . I DGEC2(5)]"" W ", "_$$GET1^DIQ(5,+DGEC2(5),1)
  1. . . . W " ",$P(DGEC2(11),"^",2)
  1. . . I DGFOR2 D
  1. . . . W " "_$$GET1^DIQ(2,DFN_",",.331013)_" "_$$GET1^DIQ(2,DFN_",",.331014)
  1. . ; DG*5.3*997;jam; ECs Country
  1. . I DGCNTRY1]"" W !?14,$E(DGCNTRY1,1,30)
  1. . I DGCNTRY1']"" W !
  1. . W ?50,$E(DGCNTRY2,1,30)
  1. . ;Home and work phones
  1. . W !,?7,"Phone: ",$S(DGEC1(8)]"":DGEC1(8),1:"UNSPECIFIED")
  1. . I DGEC2(9)]"" W ?43,"Phone: ",$S(DGEC2(8)]"":DGEC2(8),1:"UNSPECIFIED")
  1. . W !?2,"Work Phone: ",$S($P(^DPT(DFN,.33),U,11)]"":$P(^DPT(DFN,.33),U,11),1:"UNSPECIFIED")
  1. . I DGEC2(9)]"" W ?38,"Work Phone: ",$S($P(^DPT(DFN,.331),U,11)]"":$P(^DPT(DFN,.331),U,11),1:"UNSPECIFIED")
  1. D KVAR^VADPT
  1. Q
  1. ;
  1. CATDIS ;
  1. ;displays catastrophic disabity review date if there is one
  1. N DGCDIS
  1. Q:'$G(DFN)
  1. I $$GET^DGENCDA(DFN,.DGCDIS) D
  1. .Q:'DGCDIS("REVDTE")
  1. .W !!,"Catastrophically Disabled Review Date: ",$$FMTE^XLFDT(DGCDIS("REVDTE"),1)
  1. Q
  1. HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
  1. ;MPI/PD CHANGE
  1. ;DJE DG*5.3*935 - Add Member ID To Vista Registration Banner - RM#879322 (added SSNNM call)
  1. ;ARF DG*5.3*985 - Add Preferred Name to Patient Inquiry banner
  1. N X,DGLN,DGSSNNM,DGSSNNM1,DGPRFNAM,DGSSN,DGEPI,DGNAME,DGDOB,DGCNT,DGLINE,DIWL,DIWR,DIWF
  1. ;W @IOF,!,$$SSNNM^DGRPU(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,! Q ;**863 - MVI_2351 (ptd)
  1. ;END MPI/PD CHANGE
  1. ;ARF DG*5.3*985 - replace previous code for the banner with logic to pull out individual fields to place them in proper order
  1. S DGPRFNAM=$$GET1^DIQ(2,+DFN_",",.2405,"E")
  1. S:DGPRFNAM'="" DGPRFNAM="("_DGPRFNAM_")"
  1. S DGSSNNM=$$SSNNM^DGRPU(DFN)
  1. S DGNAME=$P(DGSSNNM,";",1)_";"
  1. S DGSSNNM1=$P(DGSSNNM,";",2)
  1. S DGSSN=$P(DGSSNNM1," ",3)
  1. S DGEPI=$S($P(DGSSNNM1," ",2)'="":" "_$P(DGSSNNM1," ",2),1:"")
  1. S DGDOB=$P(VADM(3),"^",2)
  1. S DGDOB=$TR(DGDOB," ","_") ;replaced space in DGDOB with "_" for the ^DIWP utility
  1. ;ARF DG*5.3*985 - create the string of fields for the banner
  1. S X=DGNAME_DGPRFNAM_DGEPI_" "_DGSSN_" "_DGDOB
  1. W @IOF,!
  1. ;ARF DG*5.3*985 - use ^DIWP to insure proper wrapping if string goes beyond 80 chars
  1. K ^UTILITY($J,"W") S DIWL=0,DIWR=79,DIWF="" D ^DIWP
  1. S DGCNT=^UTILITY($J,"W",0)
  1. F DGLN=1:1:DGCNT S DGLINE=$TR(^UTILITY($J,"W",0,DGLN,0),"_"," ") W !,DGLINE ;replaced "_" for display
  1. S X="",$P(X,"=",78)="" W !,X,!
  1. K ^UTILITY($J,"W")
  1. OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE
  1. ;
  1. ;IN: DGLINE --MAX LINE COUNT W/O PAUSE
  1. ;OUT: DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW
  1. ; DGRPOUT[SET] -- 1 IF "
  1. N X,Y ;**286** MLR 09/25/00 Newing X & Y variables prior to ^DIR
  1. I $G(IOST)["P-" Q DGLINE ; if printer, quit
  1. I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0
  1. Q DGLINE
  1. ;