source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCADD.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
RevLine 
[613]1DGRPCADD ;ALB/MRL - REGISTRATION SCREEN 1.1/CONFIDENTIAL ADDRESS INFORMATION ;FEB 2003@2300
2 ;;5.3;Registration;**489,624**;Aug 13, 1993
3CADD ;Confidential Address
4 N CNT,DGA1,DGA2,DGA3,DGACT,DGBEG,DGCAN,DGCAT,DGCC,DGEND,DGTYP,DGTYPNAM,DGX,DGXX,DGZ,DGZIP,DGI,Y,Z,DGERR
5 S DGRPS=1.1 D H^DGRPU
6 S DGRP(.141)=$G(^DPT(DFN,.141))
7 S Z=1,DGRPW=1.1 D WW^DGRPV W "Confidential Address"
8 I DGRP(.141)=""!($P(DGRP(.141),U)="")!('$P($$CAACT(DFN),U)) D G END
9 .W !?5,"NO CONFIDENTIAL ADDRESS"
10 .W !!?42,"From/To: NOT APPLICABLE"
11 S DGXX=DGRP(.141),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3)
12 W !?3,DGA1,?43,"County: "
13 I $D(^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0)) D
14 .S DGCC=^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0) W $P(DGCC,"^",1),"(",$P(DGCC,"^",3),")"
15 W:DGA2'="" !?3,DGA2
16 W:DGA3'="" !?3,DGA3
17 W !?3,$P(DGRP(.141),"^",4) I $D(^DIC(5,+$P(DGRP(.141),"^",5),0)) W ",",$P(^DIC(5,+$P(DGRP(.141),"^",5),0),"^",2)
18 S DGZIP=$P(DGRP(.141),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
19 W " ",DGZIP
20 W ?42,"From/To: " S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D
21 .I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y
22 .I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED")
23 W DGX
24 W !!,"Categories: " I $D(^DPT(DFN,.14)) D
25 .S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
26 .S DGX="",DGCAN="" F S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN="" D
27 ..Q:'$D(^DPT(DFN,.14,DGCAN,0))
28 ..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2)
29 ..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
30 ..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM="" D
31 ...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
32 S DGXX="",CNT=0 F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX="" D
33 .W:CNT>0 !
34 .W ?13,DGXX
35 .S CNT=CNT+1
36END ;
37 S DGRP(.13)=$G(^DPT(DFN,.13))
38 S Z=2,DGRPW=1.1 D WW^DGRPV W " Cell Phone: "
39 ;
40 ;* Output Cell phone
41 I $P(DGRP(.13),U,4)'="" W ?20,$P(DGRP(.13),U,4)
42 I $P(DGRP(.13),U,4)="" W ?20,"UNANSWERED"
43 ;
44 ;* Output Pager
45 W !," Pager #: "
46 I $P(DGRP(.13),U,5)'="" W ?19,$P(DGRP(.13),U,5)
47 I $P(DGRP(.13),U,5)="" W ?19,"UNANSWERED"
48 ;
49 ;* Output Email Address
50 W !," Email Address: "
51 I $P(DGRP(.13),U,3)'="" W ?19,$P(DGRP(.13),U,3)
52 I $P(DGRP(.13),U,3)="" W ?19,"UNANSWERED"
53 ;
54 G ^DGRPP
55CAACT(DFN,ACTDT) ;Determines if the Confidential Address is active
56 ;Input: DFN - Patient (#2) file internal entry number (Required)
57 ; ACTDT - Date used to determine if address is active
58 ; (Optional) Defaults to DT if not defined.
59 ;
60 ;Output:
61 ; 1st piece 0 inactive based on start/stop dates
62 ; 1 active based on start/stop dates
63 ; 2nd piece 0 - no active correspondence types
64 ; 1 - at least one active correspondence type
65 ;
66 N DGCA,DGCABEG,DGCAEND,DGSTAT,DGIEN,DGTYP,DGFLG
67 S DGSTAT="0^0"
68 I '$D(DFN) Q DGSTAT
69 I '$D(ACTDT) S ACTDT=DT
70 S DGCA=$G(^DPT(DFN,.141)) D
71 .I DGCA="" Q
72 .S DGCABEG=$P(DGCA,U,7)
73 .S DGCAEND=$P(DGCA,U,8)
74 .I 'DGCABEG!(DGCABEG>ACTDT)!(DGCAEND&(DGCAEND<ACTDT)) Q
75 .S DGSTAT="1^0"
76 ;Build array of correspondence types
77 S (DGIEN,DGFLG)=0
78 F S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN D Q:DGFLG
79 .S DGTYP=$G(^DPT(DFN,.14,+DGIEN,0))
80 .I $P(DGTYP,U,2)="Y" S DGFLG=1
81 S $P(DGSTAT,U,2)=$S(DGFLG=1:1,1:0)
82 Q DGSTAT
Note: See TracBrowser for help on using the repository browser.