DGRPCADD.m

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