DGRPD.m

DGRPD ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC/BAJ-PATIENT INQUIRY (NEW) ; 05/03/06

 ;;5.3;PIMS;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,1015,1016**;JUN 30, 2012;Build 20

 ;  *286*  Newing variables X,Y in OKLINE subroutine

 ;  *358*  If a patient is on a domiciliary ward, don't display MEANS

 ;         TEST required/Medication Copayment Exemption messages

 ;  *436*  If an inpatient is not on a domiciliary ward, don't display

 ;         Medication Copayment Exemption message

 ;  *545*  Add death information near the remarks field

 ;  *677*  Added Emergency Response

 ;  *688*  Modified to display Country and Foreign Address

 ;IHS/ANMC/LJF  3/16/2001 removed limit on # of future appt to display

 ;ihs/cmi/maw 06/18/2012 PATCH 1015 K VAROOT because call to EC^DGRPD1 leaves it

SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL

EN ;call to display patient inquiry - input DFN

 ;MPI/PD CHANGE

 S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))

 S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")

 I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^")

 ;END MPI/PD CHANGE

 K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR^DGRPD1 F I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")

 S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'<DT:1,1:0) I DGTMPAD S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU

 W ?1,"Address: ",$S($D(DGA(1)):DGA(1),1:"NONE ON FILE"),?40,"Temporary: ",$S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")

 S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>50) !?9 W:'(I#2) ?48 W DGA(I)

 S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU)

 N DGCNTRY,DGFORGN S DGCNTRY=$P(DGRP(.11),"^",10),DGFORGN=$$FORIEN^DGADDUTL(DGCNTRY) I 'DGFORGN W !?2,"County: ",DGCC

 S X="NOT APPLICABLE" I DGTMPAD S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)

 N DGSKIP S DGSKIP=$S(DGFORGN:"!,?42,""From/To: """,1:"?42, ""From/To: """)

 W @DGSKIP,X,!?3,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPADW

 W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)

 W !?4,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU)

 W !?2,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU)

 W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN))

 D CA

 N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^"))

 W:DGEMER]"" !?32,"Emergency Response: ",DGEMER

 I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED")

 I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED")

 I 'DGABBRV W ! D

 .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF

 .K ^UTILITY($J,"W")

 .S PTR=0 F  S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR  D

 ..S VAL=+$G(^DPT(DFN,.02,PTR,0))

 ..Q:$$INACTIVE^DGUTL4(VAL,1)

 ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "

 ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP

 .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"

 .K ^UTILITY($J,"W")

 .S PTR=0 F  S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR  D

 ..S VAL=+$G(^DPT(DFN,.06,PTR,0))

 ..Q:$$INACTIVE^DGUTL4(VAL,2)

 ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "

 ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP

 .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"

 .K ^UTILITY($J,"W")

 .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)

 .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0))  W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))

 I '$$OKLINE^DGRPD1(16) G Q

 ;display cv status #4156

 N DGCV S DGCV=$$CVEDT^DGCV(+DFN)

 W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")

 ;display primary eligibility

 S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)

 W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I  I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X

 I '$$OKLINE^DGRPD1(16) G Q

 ;employability status

 W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO")

 ;display the catastrophic disability review date if there is one

 D CATDIS^DGRPD1

 I $G(DGPRFLG)=1 G Q:'$$OKLINE^DGRPD1(19) D

 . N DGPDT,DGPTM

 . W !,$$REPEAT^XLFSTR("-",78)

 . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)

 . W !,"[PRE-REGISTER DATE:]  "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")

 . S DGPTM=$$PCTEAM^DGSDUTL(DFN)

 . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)

 . W !,$$REPEAT^XLFSTR("-",78)

 ; Check if patient is an inpatient and on a DOM ward

 ; If inpatient is on a DOM ward, don't display MT or CP messages

 ; If inpatient is NOT on a DOM ward, don't display CP message

 N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR

 G Q:'$$OKLINE^DGRPD1(14)

 D DOM^DGMTR

 I '$G(DGDOM) D

 .D DIS^DGMTU(DFN)

 .D IN5^VADPT

 .;ihs/cmi/maw 05/09/2012 patch 1016 no IB

 .;I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)

 ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !

 ;D DIS^EASECU(DFN)   ;Added for LTC III (DG*5.3*518)

 S VAIP("L")=""

 I $$OKLINE^DGRPD1(14) D INP

 I '$G(DGRPOUT),($$OKLINE^DGRPD1(17)) D SA

 ;MPI/PD CHANGE

Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q

CA ;Confidential Address

 W !!?1,"Confidential Address:  ",?44,"Confidential Address Categories:"

 N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR

 S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)

 I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) D  Q

 .W !?9,"NO CONFIDENTIAL ADDRESS"

 .W !?1,"From/To: NOT APPLICABLE"

 S DGAD=.141,(DGA1,DGA2)=1

 D AL^DGRPU(30)

 D GETS^DIQ(2,DFN,".141*,","E","DGARRAY","DGERROR")

 ;Format Confidential Address categories

 N DGIEN,DGCAST

 S DGIEN=0

 S DGA2=2

 F  S DGIEN=$O(DGARRAY(2.141,DGIEN)) Q:'DGIEN  D

 .S DGA(DGA2)=DGARRAY(2.141,DGIEN,.01,"E")

 .S DGCAST=DGARRAY(2.141,DGIEN,1,"E")

 .S DGA(DGA2)=DGA(DGA2)_"("_$S(DGCAST="YES":"Active",1:"Inactive")_")"

 .S DGA2=DGA2+2

 S I=0 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>43) !?9 W:'(I#2) ?44 W DGA(I)

 W !?1,"From/To:  ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED")

 Q

INP S VAIP("D")="L" D INP^DGPMV10

 S DGPMT=0

 D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q

SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE^DGRPD1(17) SAA Q:$G(DGRPOUT)

 Q

SAA ;Scheduled Admit Data

 W !!?14,"Scheduled Admit"

 W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)

 W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)

 W " on "_$$FMTE^XLFDT(L,"5DZ")

 Q  ;SAA

 ;

CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I  I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"")

 ;

FA G:'$$OKLINE^DGRPD1(20) RMK

 ;

 N DGARRAY,SDCNT

 S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"

 S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: "

 ;if there is lower subscripts hanging from the 101 node,

 ;then it is a valid appointment, otherwise it is

 ;an error eg 01/20/2005

 I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK

 I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK

 ;

 W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="

 ;F FA=DT:0 S FA=$O(^DPT(DFN,"S",FA)) G RMK:'FA S L=^(FA,0),C=+L I $P(L,"^",2)'["C" D COV D  Q:CT>5  ;IHS/ANMC/LJF 3/16/2001

 F FA=DT:0 S FA=$O(^DPT(DFN,"S",FA)) G RMK:'FA S L=^(FA,0),C=+L  D  ;I $P(L,"^",2)'["C" D COV D           ;IHS/ANMC/LJF 3/16/2001

 .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";")

 .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D

 ..D COV

 ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")

 ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2)

 ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV

 ..Q

 I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments."

RMK I '$G(DGRPOUT),($$OKLINE^DGRPD1(21)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10)

 D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")

 W !!

 W "Date of Death Information"

 W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))

 W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))

 W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))

 W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!

 I $$OKLINE^DGRPD1(14) D EC^DGRPD1

 K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky

 K VAROOT  ;ihs/cmi/maw 06/18/2012 PATCH 1015 exists after call to EC^DGRPD1

 Q

COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")

 S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q

 Q

 ;

OREN S XQORQUIT=1 Q:'$D(ORVP)  S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME

 Q

DGRPD     ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC/BAJ-PATIENT INQUIRY (NEW) ; 05/03/06

 +1       ;;5.3;PIMS;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,1015,1016**;JUN 30, 2012;Build 20

 +2       ;  *286*  Newing variables X,Y in OKLINE subroutine

 +3       ;  *358*  If a patient is on a domiciliary ward, don't display MEANS

 +4       ;         TEST required/Medication Copayment Exemption messages

 +5       ;  *436*  If an inpatient is not on a domiciliary ward, don't display

 +6       ;         Medication Copayment Exemption message

 +7       ;  *545*  Add death information near the remarks field

 +8       ;  *677*  Added Emergency Response

 +9       ;  *688*  Modified to display Country and Foreign Address

 +10      ;IHS/ANMC/LJF  3/16/2001 removed limit on # of future appt to display

 +11      ;ihs/cmi/maw 06/18/2012 PATCH 1015 K VAROOT because call to EC^DGRPD1 leaves it

SEL        KILL DFN,DGRPOUT

           WRITE !

           SET DIC="^DPT("

           SET DIC(0)="AEQMZ"

           DO ^DIC

           IF Y'>0

               GOTO Q

           SET DFN=+Y

           NEW Y

           WRITE !

           SET DIR(0)="E"

           DO ^DIR

           IF $DATA(DTOUT)!($DATA(DUOUT))

               GOTO SEL

           DO EN

           GOTO SEL

EN        ;call to display patient inquiry - input DFN

 +1       ;MPI/PD CHANGE

 +2        SET DGCMOR="UNSPECIFIED"

           SET DGMPI=$GET(^DPT(+DFN,"MPI"))

 +3        SET DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$PIECE(DGMPI,U,3))

           SET DGLOCATN=$SELECT(+DGLOCATN>0:$PIECE($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")

 +4        IF $DATA(DGMPI)

               IF $DATA(DGLOCATN)

                   SET DGCMOR=$PIECE(DGLOCATN,"^")

 +5       ;END MPI/PD CHANGE

 +6        KILL DGRPOUT,DGHOW

           SET DGABBRV=$SELECT($DATA(^DG(43,1,0)):+$PIECE(^(0),"^",38),1:0)

           SET DGRPU="UNSPECIFIED"

           DO DEM^VADPT

           DO HDR^DGRPD1

           FOR I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3

               SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")

 +7        SET DGAD=.11

           SET (DGA1,DGA2)=1

           DO A^DGRPU

           SET DGTMPAD=0

           IF $PIECE(DGRP(.121),"^",9)="Y"

               SET DGTMPAD=$SELECT('$PIECE(DGRP(.121),"^",8):1,$PIECE(DGRP(.121),"^",8)'<DT:1,1:0)

               IF DGTMPAD

                   SET DGAD=.121

                   SET DGA1=1

                   SET DGA2=2

                   DO A^DGRPU

 +8        WRITE ?1,"Address: ",$SELECT($DATA(DGA(1)):DGA(1),1:"NONE ON FILE"),?40,"Temporary: ",$SELECT($DATA(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")

 +9        SET I=2

           FOR I1=0:0

               SET I=$ORDER(DGA(I))

               IF I=""

                   QUIT 

               IF (I#2)!($X>50)

                   WRITE !?9

               IF '(I#2)

                   WRITE ?48

               WRITE DGA(I)

 +10       SET DGCC=+$PIECE(DGRP(.11),U,7)

           SET DGST=+$PIECE(DGRP(.11),U,5)

           SET DGCC=$SELECT($DATA(^DIC(5,DGST,1,DGCC,0)):$EXTRACT($PIECE(^(0),U,1),1,20)_$SELECT($PIECE(^(0),U,3)]"":" ("_$PIECE(^(0),U,3)_")",1:""),1:DGRPU)

 +11       NEW DGCNTRY,DGFORGN

           SET DGCNTRY=$PIECE(DGRP(.11),"^",10)

           SET DGFORGN=$$FORIEN^DGADDUTL(DGCNTRY)

           IF 'DGFORGN

               WRITE !?2,"County: ",DGCC

 +12       SET X="NOT APPLICABLE"

           IF DGTMPAD

               SET Y=$PIECE(DGRP(.121),U,7)

               IF Y]""

                   XECUTE ^DD("DD")

               SET X=$SELECT(Y]"":Y,1:DGRPU)_"-"

               SET Y=$PIECE(DGRP(.121),U,8)

               IF Y]""

                   XECUTE ^DD("DD")

               SET X=X_$SELECT(Y]"":Y,1:DGRPU)

 +13       NEW DGSKIP

           SET DGSKIP=$SELECT(DGFORGN:"!,?42,""From/To: """,1:"?42, ""From/To: """)

 +14       WRITE @DGSKIP,X,!?3,"Phone: ",$SELECT($PIECE(DGRP(.13),U,1)]"":$PIECE(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$SELECT('DGTMPAD:X,$PIECE(DGRP(.121),U,10)]"":$PIECE(DGRP(.121),U,10),1:DGRPU)

           KILL DGTMPADW

 +15       WRITE !?2,"Office: ",$SELECT($PIECE(DGRP(.13),U,2)]"":$PIECE(DGRP(.13),U,2),1:DGRPU)

 +16       WRITE !?4,"Cell: ",$SELECT($PIECE(DGRP(.13),U,4)]"":$PIECE(DGRP(.13),U,4),1:DGRPU)

 +17       WRITE !?2,"E-mail: ",$SELECT($PIECE(DGRP(.13),U,3)]"":$PIECE(DGRP(.13),U,3),1:DGRPU)

 +18       WRITE !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN))

 +19       DO CA

 +20       NEW DGEMER

           SET DGEMER=$$EXTERNAL^DILFD(2,.181,"",$PIECE($GET(^DPT(DFN,.18)),"^"))

 +21       IF DGEMER]""

               WRITE !?32,"Emergency Response: ",DGEMER

 +22       IF 'DGABBRV

               WRITE !!?4,"POS: ",$SELECT($DATA(^DIC(21,+$PIECE(DGRP(.32),"^",3),0)):$PIECE(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$SELECT($PIECE(DGRP(.31),"^",3)]"":$PIECE(DGRP(.31),"^",3),1:"UNSPECIFIED")

 +23       IF 'DGABBRV

               WRITE !?2,"Relig: ",$SELECT($DATA(^DIC(13,+$PIECE(DGRP(0),"^",8),0)):$PIECE(^(0),"^",1),1:DGRPU),?46,"Sex: ",$SELECT($PIECE(VADM(5),"^",2)]"":$PIECE(VADM(5),"^",2),1:"UNSPECIFIED")

 +24       IF 'DGABBRV

               WRITE !

               Begin DoDot:1

 +25               NEW RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF

 +26               KILL ^UTILITY($JOB,"W")

 +27               SET PTR=0

                   FOR 

                       SET PTR=+$ORDER(^DPT(DFN,.02,PTR))

                       IF 'PTR

                           QUIT 

                       Begin DoDot:2

 +28                       SET VAL=+$GET(^DPT(DFN,.02,PTR,0))

 +29                       IF $$INACTIVE^DGUTL4(VAL,1)

                               QUIT 

 +30                       SET VAL=$$PTR2TEXT^DGUTL4(VAL,1)

                           IF +$ORDER(^DPT(DFN,.02,PTR))

                               SET VAL=VAL_", "

 +31                       SET X=VAL

                           SET DIWL=0

                           SET DIWR=30

                           SET DIWF=""

                           DO ^DIWP

                       End DoDot:2

 +32               MERGE RACE=^UTILITY($JOB,"W",0)

                   IF $GET(RACE(1,0))=""

                       SET RACE(1,0)="UNANSWERED"

 +33               KILL ^UTILITY($JOB,"W")

 +34               SET PTR=0

                   FOR 

                       SET PTR=+$ORDER(^DPT(DFN,.06,PTR))

                       IF 'PTR

                           QUIT 

                       Begin DoDot:2

 +35                       SET VAL=+$GET(^DPT(DFN,.06,PTR,0))

 +36                       IF $$INACTIVE^DGUTL4(VAL,2)

                               QUIT 

 +37                       SET VAL=$$PTR2TEXT^DGUTL4(VAL,2)

                           IF +$ORDER(^DPT(DFN,.06,PTR))

                               SET VAL=VAL_", "

 +38                       SET X=VAL

                           SET DIWL=0

                           SET DIWR=30

                           SET DIWF=""

                           DO ^DIWP

                       End DoDot:2

 +39               MERGE ETHNIC=^UTILITY($JOB,"W",0)

                   IF $GET(ETHNIC(1,0))=""

                       SET ETHNIC(1,0)="UNANSWERED"

 +40               KILL ^UTILITY($JOB,"W")

 +41               WRITE ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)

 +42               FOR X=2:1

                       IF '$DATA(RACE(X,0))&'$DATA(ETHNIC(X,0))

                           QUIT 

                       WRITE !,?9,$GET(RACE(X,0)),?51,$GET(ETHNIC(X,0))

               End DoDot:1

 +43       IF '$$OKLINE^DGRPD1(16)

               GOTO Q

 +44      ;display cv status #4156

 +45       NEW DGCV

           SET DGCV=$$CVEDT^DGCV(+DFN)

 +46       WRITE !!,?2,"Combat Vet Status: "_$SELECT($PIECE(DGCV,U,3)=1:"ELIGIBLE",$PIECE(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED")

           IF DGCV>0

               WRITE ?45,"End Date: "_$$FMTE^XLFDT($PIECE(DGCV,U,2),"5DZ")

 +47      ;display primary eligibility

 +48       SET X1=DGRP(.36)

           SET X=$PIECE(DGRP(.361),"^",1)

           WRITE !,"Primary Eligibility: ",$SELECT($DATA(^DIC(8,+X1,0)):$PIECE(^(0),"^",1)_" ("_$SELECT(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)

 +49       WRITE !,"Other Eligibilities: "

           FOR I=0:0

               SET I=$ORDER(^DIC(8,I))

               IF 'I

                   QUIT 

               IF $DATA(^DIC(8,I,0))

                   IF I'=+X1

                       SET X=$PIECE(^(0),"^",1)_", "

                       IF $DATA(^DPT("AEL",DFN,I))

                           IF $X+$LENGTH(X)>79

                               WRITE !?21

                           WRITE X

 +50       IF '$$OKLINE^DGRPD1(16)

               GOTO Q

 +51      ;employability status

 +52       WRITE !?6,"Unemployable: ",$SELECT($PIECE(DGRP(.3),U,5)="Y":"YES",1:"NO")

 +53      ;display the catastrophic disability review date if there is one

 +54       DO CATDIS^DGRPD1

 +55       IF $GET(DGPRFLG)=1

               IF '$$OKLINE^DGRPD1(19)

                   GOTO Q

               Begin DoDot:1

 +56               NEW DGPDT,DGPTM

 +57               WRITE !,$$REPEAT^XLFSTR("-",78)

 +58               SET DGPDT=""

                   SET DGPDT=$ORDER(^DGS(41.41,"ADC",DFN,DGPDT),-1)

 +59               WRITE !,"[PRE-REGISTER DATE:]  "_$SELECT(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")

 +60               SET DGPTM=$$PCTEAM^DGSDUTL(DFN)

 +61               IF $PIECE(DGPTM,U,2)]""

                       WRITE !,"[PRIMARY CARE TEAM:] "_$PIECE(DGPTM,U,2)

 +62               WRITE !,$$REPEAT^XLFSTR("-",78)

               End DoDot:1

 +63      ; Check if patient is an inpatient and on a DOM ward

 +64      ; If inpatient is on a DOM ward, don't display MT or CP messages

 +65      ; If inpatient is NOT on a DOM ward, don't display CP message

 +66       NEW DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR

 +67       IF '$$OKLINE^DGRPD1(14)

               GOTO Q

 +68       DO DOM^DGMTR

 +69       IF '$GET(DGDOM)

               Begin DoDot:1

 +70               DO DIS^DGMTU(DFN)

 +71               DO IN5^VADPT

 +72      ;ihs/cmi/maw 05/09/2012 patch 1016 no IB

 +73      ;I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)

               End DoDot:1

 +74      ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !

 +75      ;D DIS^EASECU(DFN)   ;Added for LTC III (DG*5.3*518)

 +76       SET VAIP("L")=""

 +77       IF $$OKLINE^DGRPD1(14)

               DO INP

 +78       IF '$GET(DGRPOUT)

               IF ($$OKLINE^DGRPD1(17))

                   DO SA

 +79      ;MPI/PD CHANGE

Q          DO KVA^VADPT

           KILL %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y

           QUIT 

CA        ;Confidential Address

 +1        WRITE !!?1,"Confidential Address:  ",?44,"Confidential Address Categories:"

 +2        NEW DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR

 +3        SET DGCABEG=$PIECE(DGRP(.141),U,7)

           SET DGCAEND=$PIECE(DGRP(.141),U,8)

 +4        IF 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT))

               Begin DoDot:1

 +5                WRITE !?9,"NO CONFIDENTIAL ADDRESS"

 +6                WRITE !?1,"From/To: NOT APPLICABLE"

               End DoDot:1

               QUIT 

 +7        SET DGAD=.141

           SET (DGA1,DGA2)=1

 +8        DO AL^DGRPU(30)

 +9        DO GETS^DIQ(2,DFN,".141*,","E","DGARRAY","DGERROR")

 +10      ;Format Confidential Address categories

 +11       NEW DGIEN,DGCAST

 +12       SET DGIEN=0

 +13       SET DGA2=2

 +14       FOR 

               SET DGIEN=$ORDER(DGARRAY(2.141,DGIEN))

               IF 'DGIEN

                   QUIT 

               Begin DoDot:1

 +15               SET DGA(DGA2)=DGARRAY(2.141,DGIEN,.01,"E")

 +16               SET DGCAST=DGARRAY(2.141,DGIEN,1,"E")

 +17               SET DGA(DGA2)=DGA(DGA2)_"("_$SELECT(DGCAST="YES":"Active",1:"Inactive")_")"

 +18               SET DGA2=DGA2+2

               End DoDot:1

 +19       SET I=0

           FOR I1=0:0

               SET I=$ORDER(DGA(I))

               IF I=""

                   QUIT 

               IF (I#2)!($X>43)

                   WRITE !?9

               IF '(I#2)

                   WRITE ?44

               WRITE DGA(I)

 +20       WRITE !?1,"From/To:  ",$$FMTE^XLFDT(DGCABEG)_"-"_$SELECT(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED")

 +21       QUIT 

INP        SET VAIP("D")="L"

           DO INP^DGPMV10

 +1        SET DGPMT=0

 +2        DO CS^DGPMV10

           KILL DGPMT,DGPMIFN

           IF '$DATA(DGSWITCH)

               KILL DGPMVI,DGPMDCD

           QUIT 

SA         FOR I=0:0

               SET I=$ORDER(^DGS(41.1,"B",DFN,I))

               IF 'I

                   GOTO CL

               SET X=^DGS(41.1,I,0)

               IF $PIECE(X,"^",2)>(DT-1)

                   IF $PIECE(X,"^",13)']""

                       IF '$PIECE(X,"^",17)

                           SET L=$PIECE(X,"^",2)

                           IF $$OKLINE^DGRPD1(17)

                               DO SAA

                           IF $GET(DGRPOUT)