DGRPCADD ;ALB/MRL,BAJ,TDM - REGISTRATION SCREEN 1.1/CONFIDENTIAL ADDRESS INFORMATION ; 9/29/09 1:16pm
;;5.3;PIMS;**489,624,688,1015,1016**;JUN 30, 2012;Build 20
;;**688 BAJ Jan 17,2006 Modifications to support Foreign addresses
CADD ;Confidential Address
N CNT,DGA1,DGA2,DGA3,DGA4,DGACT,DGBEG,DGCAN,DGCAT,DGCC,DGEND,DGTYP,DGTYPNAM,DGX,DGXX,DGZ,DGZIP,DGI,Y,Z,DGERR
N DGA14,DGA15,DGA16,FORGN,DGCNTRY,DGA1315
S DGRPS=1.1 D H^DGRPU
S DGRP(.141)=$G(^DPT(DFN,.141))
S Z=1,DGRPW=1.1 D WW^DGRPV W "Confidential Address"
; if no data or no Category, display "NO CONFIDENTIAL..."
;I DGRP(.141)=""!($P(DGRP(.141),U)="")!('$P($$CAACT(DFN),U)) D G END
I DGRP(.141)=""!('$P($$CAACT(DFN),U)) D G END
.W !?5,"NO CONFIDENTIAL ADDRESS"
.W !!?42,"From/To: NOT APPLICABLE"
S DGXX=DGRP(.141),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4)
S DGA14=$P(DGXX,"^",14),DGA15=$P(DGXX,"^",15)
S DGA16=$P(DGXX,"^",16) S:'DGA16 DGA16=""
S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA16),1,25),FORGN=$$FORIEN^DGADDUTL(DGA16)
I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY"
W:DGA1'="" !?3,DGA1
I 'FORGN D
. ;If we didn't skip a line for Address Line 1, skip line now
. I DGA1="" W !
. W ?43,"County: "
. I $D(^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0)) D
. . S DGCC=^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0) W $P(DGCC,"^",1),"(",$P(DGCC,"^",3),")"
S DGA1315=$P($G(^DPT(DFN,.13)),U,15) S:DGA1315="" DGA1315="UNANSWERED"
I DGA2'="" W !?3,DGA2,?44,"Phone: ",DGA1315
I DGA3'="" W !?3,DGA3 I DGA2="" W ?44,"Phone: ",DGA1315
I FORGN W !?3,DGA15_" "_DGA4_" "_DGA14
I 'FORGN W !?3,DGA4 D
. I $D(^DIC(5,+$P(DGRP(.141),"^",5),0)) W ",",$P(^DIC(5,+$P(DGRP(.141),"^",5),0),"^",2)
. S DGZIP=$P(DGRP(.141),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12)
. W " ",DGZIP
I DGA2="",DGA3="" W ?44,"Phone: ",DGA1315
W !?3,DGCNTRY
W ?42,"From/To: " S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D
.I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y
.I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED")
W DGX
W !!,"Categories: " I $D(^DPT(DFN,.14)) D
.S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
.S DGX="",DGCAN="" F S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN="" D
..Q:'$D(^DPT(DFN,.14,DGCAN,0))
..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2)
..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM="" D
...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
S DGXX="",CNT=0 F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX="" D
.W:CNT>0 !
.W ?13,DGXX
.S CNT=CNT+1
; line feed before continuing
W !
END ;
S DGRP(.13)=$G(^DPT(DFN,.13))
S Z=2,DGRPW=1.1 D WW^DGRPV W " Cell Phone: "
;
;* Output Cell phone
I $P(DGRP(.13),U,4)'="" W ?20,$P(DGRP(.13),U,4)
I $P(DGRP(.13),U,4)="" W ?20,"UNANSWERED"
;
;* Output Pager
W !," Pager #: "
I $P(DGRP(.13),U,5)'="" W ?19,$P(DGRP(.13),U,5)
I $P(DGRP(.13),U,5)="" W ?19,"UNANSWERED"
;
;* Output Email Address
W !," Email Address: "
I $P(DGRP(.13),U,3)'="" W ?19,$P(DGRP(.13),U,3)
I $P(DGRP(.13),U,3)="" W ?19,"UNANSWERED"
;
G ^DGRPP
CAACT(DFN,ACTDT) ;Determines if the Confidential Address is active
;Input: DFN - Patient (#2) file internal entry number (Required)
; ACTDT - Date used to determine if address is active
; (Optional) Defaults to DT if not defined.
;
;Output:
; 1st piece 0 inactive based on start/stop dates
; 1 active based on start/stop dates
; 2nd piece 0 - no active correspondence types
; 1 - at least one active correspondence type
;
N DGCA,DGCABEG,DGCAEND,DGSTAT,DGIEN,DGTYP,DGFLG
S DGSTAT="0^0"
I '$D(DFN) Q DGSTAT
I '$D(ACTDT) S ACTDT=DT
S DGCA=$G(^DPT(DFN,.141)) D
.I DGCA="" Q
.S DGCABEG=$P(DGCA,U,7)
.S DGCAEND=$P(DGCA,U,8)
.I 'DGCABEG!(DGCABEG>ACTDT)!(DGCAEND&(DGCAEND<ACTDT)) Q
.S DGSTAT="1^0"
;Build array of correspondence types
S (DGIEN,DGFLG)=0
F S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN D Q:DGFLG
.S DGTYP=$G(^DPT(DFN,.14,+DGIEN,0))
.I $P(DGTYP,U,2)="Y" S DGFLG=1
S $P(DGSTAT,U,2)=$S(DGFLG=1:1,1:0)
Q DGSTAT
DGRPCADD ;ALB/MRL,BAJ,TDM - REGISTRATION SCREEN 1.1/CONFIDENTIAL ADDRESS INFORMATION ; 9/29/09 1:16pm
+1 ;;5.3;PIMS;**489,624,688,1015,1016**;JUN 30, 2012;Build 20
+2 ;;**688 BAJ Jan 17,2006 Modifications to support Foreign addresses
CADD ;Confidential Address
+1 NEW CNT,DGA1,DGA2,DGA3,DGA4,DGACT,DGBEG,DGCAN,DGCAT,DGCC,DGEND,DGTYP,DGTYPNAM,DGX,DGXX,DGZ,DGZIP,DGI,Y,Z,DGERR
+2 NEW DGA14,DGA15,DGA16,FORGN,DGCNTRY,DGA1315
+3 SET DGRPS=1.1
DO H^DGRPU
+4 SET DGRP(.141)=$GET(^DPT(DFN,.141))
+5 SET Z=1
SET DGRPW=1.1
DO WW^DGRPV
WRITE "Confidential Address"
+6 ; if no data or no Category, display "NO CONFIDENTIAL..."
+7 ;I DGRP(.141)=""!($P(DGRP(.141),U)="")!('$P($$CAACT(DFN),U)) D G END
+8 IF DGRP(.141)=""!('$PIECE($$CAACT(DFN),U))
Begin DoDot:1
+9 WRITE !?5,"NO CONFIDENTIAL ADDRESS"
+10 WRITE !!?42,"From/To: NOT APPLICABLE"
End DoDot:1
GOTO END
+11 SET DGXX=DGRP(.141)
SET DGA1=$PIECE(DGXX,"^",1)
SET DGA2=$PIECE(DGXX,"^",2)
SET DGA3=$PIECE(DGXX,"^",3)
SET DGA4=$PIECE(DGXX,"^",4)
+12 SET DGA14=$PIECE(DGXX,"^",14)
SET DGA15=$PIECE(DGXX,"^",15)
+13 SET DGA16=$PIECE(DGXX,"^",16)
IF 'DGA16
SET DGA16=""
+14 SET DGCNTRY=$EXTRACT($$CNTRYI^DGADDUTL(DGA16),1,25)
SET FORGN=$$FORIEN^DGADDUTL(DGA16)
+15 IF DGCNTRY=-1
SET DGCNTRY="UNKNOWN COUNTRY"
+16 IF DGA1'=""
WRITE !?3,DGA1
+17 IF 'FORGN
Begin DoDot:1
+18 ;If we didn't skip a line for Address Line 1, skip line now
+19 IF DGA1=""
WRITE !
+20 WRITE ?43,"County: "
+21 IF $DATA(^DIC(5,+$PIECE(DGRP(.141),"^",5),1,+$PIECE(DGRP(.141),"^",11),0))
Begin DoDot:2
+22 SET DGCC=^DIC(5,+$PIECE(DGRP(.141),"^",5),1,+$PIECE(DGRP(.141),"^",11),0)
WRITE $PIECE(DGCC,"^",1),"(",$PIECE(DGCC,"^",3),")"
End DoDot:2
End DoDot:1
+23 SET DGA1315=$PIECE($GET(^DPT(DFN,.13)),U,15)
IF DGA1315=""
SET DGA1315="UNANSWERED"
+24 IF DGA2'=""
WRITE !?3,DGA2,?44,"Phone: ",DGA1315
+25 IF DGA3'=""
WRITE !?3,DGA3
IF DGA2=""
WRITE ?44,"Phone: ",DGA1315
+26 IF FORGN
WRITE !?3,DGA15_" "_DGA4_" "_DGA14
+27 IF 'FORGN
WRITE !?3,DGA4
Begin DoDot:1
+28 IF $DATA(^DIC(5,+$PIECE(DGRP(.141),"^",5),0))
WRITE ",",$PIECE(^DIC(5,+$PIECE(DGRP(.141),"^",5),0),"^",2)
+29 SET DGZIP=$PIECE(DGRP(.141),"^",6)
IF $LENGTH(DGZIP)>5
SET DGZIP=$EXTRACT(DGZIP,1,5)_"-"_$EXTRACT(DGZIP,6,12)
+30 WRITE " ",DGZIP
End DoDot:1
+31 IF DGA2=""
IF DGA3=""
WRITE ?44,"Phone: ",DGA1315
+32 WRITE !?3,DGCNTRY
+33 WRITE ?42,"From/To: "
SET (DGZ,DGX)=""
FOR DGI=7,8
SET DGZ=$PIECE(DGRP(.141),"^",DGI)
SET Y=DGZ
Begin DoDot:1
+34 IF DGI=7
IF Y]""
XECUTE ^DD("DD")
SET DGBEG=Y
SET DGX=Y
+35 IF DGI=8
IF Y]""
XECUTE ^DD("DD")
SET DGEND=Y
SET DGX=DGX_"-"_$SELECT(Y]"":Y,1:"UNANSWERED")
End DoDot:1
+36 WRITE DGX
+37 WRITE !!,"Categories: "
IF $DATA(^DPT(DFN,.14))
Begin DoDot:1
+38 SET DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
+39 SET DGX=""
SET DGCAN=""
FOR
SET DGCAN=$ORDER(^DPT(DFN,.14,DGCAN))
IF DGCAN=""
QUIT
Begin DoDot:2
+40 IF '$DATA(^DPT(DFN,.14,DGCAN,0))
QUIT
+41 SET DGTYP=$PIECE(^DPT(DFN,.14,DGCAN,0),"^",1)
SET DGACT=$PIECE(^DPT(DFN,.14,DGCAN,0),"^",2)
+42 SET DGACT=$SELECT(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
+43 SET DGTYPNAM=""
FOR DGI=1:1
SET DGTYPNAM=$PIECE(DGCAT,";",DGI)
IF DGTYPNAM=""
QUIT
Begin DoDot:3
+44 IF DGTYPNAM[DGTYP
SET DGTYPNAM=$PIECE(DGTYPNAM,":",2)
SET DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
End DoDot:3
End DoDot:2
End DoDot:1
+45 SET DGXX=""
SET CNT=0
FOR DGI=1:1
SET DGXX=$PIECE(DGX,",",DGI)
IF DGXX=""
QUIT
Begin DoDot:1
+46 IF CNT>0
WRITE !
+47 WRITE ?13,DGXX
+48 SET CNT=CNT+1
End DoDot:1
+49 ; line feed before continuing
+50 WRITE !
END ;
+1 SET DGRP(.13)=$GET(^DPT(DFN,.13))
+2 SET Z=2
SET DGRPW=1.1
DO WW^DGRPV
WRITE " Cell Phone: "
+3 ;
+4 ;* Output Cell phone
+5 IF $PIECE(DGRP(.13),U,4)'=""
WRITE ?20,$PIECE(DGRP(.13),U,4)
+6 IF $PIECE(DGRP(.13),U,4)=""
WRITE ?20,"UNANSWERED"
+7 ;
+8 ;* Output Pager
+9 WRITE !," Pager #: "
+10 IF $PIECE(DGRP(.13),U,5)'=""
WRITE ?19,$PIECE(DGRP(.13),U,5)
+11 IF $PIECE(DGRP(.13),U,5)=""
WRITE ?19,"UNANSWERED"
+12 ;
+13 ;* Output Email Address
+14 WRITE !," Email Address: "
+15 IF $PIECE(DGRP(.13),U,3)'=""
WRITE ?19,$PIECE(DGRP(.13),U,3)
+16 IF $PIECE(DGRP(.13),U,3)=""
WRITE ?19,"UNANSWERED"
+17 ;
+18 GOTO ^DGRPP
CAACT(DFN,ACTDT) ;Determines if the Confidential Address is active
+1 ;Input: DFN - Patient (#2) file internal entry number (Required)
+2 ; ACTDT - Date used to determine if address is active
+3 ; (Optional) Defaults to DT if not defined.
+4 ;
+5 ;Output:
+6 ; 1st piece 0 inactive based on start/stop dates
+7 ; 1 active based on start/stop dates
+8 ; 2nd piece 0 - no active correspondence types
+9 ; 1 - at least one active correspondence type
+10 ;
+11 NEW DGCA,DGCABEG,DGCAEND,DGSTAT,DGIEN,DGTYP,DGFLG
+12 SET DGSTAT="0^0"
+13 IF '$DATA(DFN)
QUIT DGSTAT
+14 IF '$DATA(ACTDT)
SET ACTDT=DT
+15 SET DGCA=$GET(^DPT(DFN,.141))
Begin DoDot:1
+16 IF DGCA=""
QUIT
+17 SET DGCABEG=$PIECE(DGCA,U,7)
+18 SET DGCAEND=$PIECE(DGCA,U,8)
+19 IF 'DGCABEG!(DGCABEG>ACTDT)!(DGCAEND&(DGCAEND<ACTDT))
QUIT
+20 SET DGSTAT="1^0"
End DoDot:1
+21 ;Build array of correspondence types
+22 SET (DGIEN,DGFLG)=0
+23 FOR
SET DGIEN=$ORDER(^DPT(DFN,.14,DGIEN))
IF 'DGIEN
QUIT
Begin DoDot:1
+24 SET DGTYP=$GET(^DPT(DFN,.14,+DGIEN,0))
+25 IF $PIECE(DGTYP,U,2)="Y"
SET DGFLG=1
End DoDot:1
IF DGFLG
QUIT
+26 SET $PIECE(DGSTAT,U,2)=$SELECT(DGFLG=1:1,1:0)
+27 QUIT DGSTAT
