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)
QUIT
+1 QUIT
SAA ;Scheduled Admit Data
+1 WRITE !!?14,"Scheduled Admit"
+2 IF $DATA(^DIC(42,+$PIECE(X,U,8),0))
WRITE " on ward "_$PIECE(^(0),U)
+3 IF $DATA(^DIC(45.7,+$PIECE(X,U,9),0))
WRITE " for treating specialty "_$PIECE(^(0),U)
+4 WRITE " on "_$$FMTE^XLFDT(L,"5DZ")
+5 ;SAA
QUIT
+6 ;
CL IF $ORDER(^DPT(DFN,"DE",0))=""
GOTO FA
SET SDCT=0
FOR I=0:0
SET I=$ORDER(^DPT(DFN,"DE",I))
IF 'I
QUIT
IF $DATA(^(I,0))
IF $PIECE(^(0),"^",2)'="I"
IF $ORDER(^(0))
SET SDCT=SDCT+1
IF SDCT=1
WRITE !!,"Currently enrolled in "
IF $X>50
WRITE !?22
WRITE $SELECT($DATA(^SC(+^(0),0)):$PIECE(^(0),"^",1)_", ",1:"")
+1 ;
FA IF '$$OKLINE^DGRPD1(20)
GOTO RMK
+1 ;
+2 NEW DGARRAY,SDCNT
+3 SET DGARRAY("FLDS")="1;2;3;18"
SET DGARRAY(4)=DFN
SET DGARRAY(1)=DT
SET DGARRAY("SORT")="P"
+4 SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
SET CT=0
WRITE !!,"Future Appointments: "
+5 ;if there is lower subscripts hanging from the 101 node,
+6 ;then it is a valid appointment, otherwise it is
+7 ;an error eg 01/20/2005
+8 IF $DATA(^TMP($JOB,"SDAMA301",101))=1
WRITE "Appointment Database is Unavailable"
GOTO RMK
+9 IF $ORDER(^TMP($JOB,"SDAMA301",DFN,DT))'>0
WRITE "NONE"
GOTO RMK
+10 ;
+11 WRITE ?22,"Date",?33,"Time",?39,"Clinic",!?22
FOR I=22:1:75
WRITE "="
+12 ;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
+13 ;I $P(L,"^",2)'["C" D COV D ;IHS/ANMC/LJF 3/16/2001
FOR FA=DT:0
SET FA=$ORDER(^DPT(DFN,"S",FA))
IF 'FA
GOTO RMK
SET L=^(FA,0)
SET C=+L
Begin DoDot:1
+14 NEW STAT
SET STAT=$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,FA),U,3),";")
+15 SET C=+$PIECE(^TMP($JOB,"SDAMA301",DFN,FA),U,2)
IF STAT'["C"
Begin DoDot:2
+16 DO COV
+17 NEW DGAPPT
SET DGAPPT=$$FMTE^XLFDT($EXTRACT(FA,1,12),"5Z")
+18 WRITE !?22,$PIECE(DGAPPT,"@"),?33,$PIECE(DGAPPT,"@",2)
+19 WRITE ?39,$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
+20 QUIT
End DoDot:2
End DoDot:1
+21 IF $ORDER(^TMP($JOB,"SDAMA301",DFN,FA))>0
WRITE !,"See Scheduling options for additional appointments."
RMK IF '$GET(DGRPOUT)
IF ($$OKLINE^DGRPD1(21))
WRITE !!,"Remarks: ",$PIECE(^DPT(DFN,0),"^",10)
+1 DO GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
+2 WRITE !!
+3 WRITE "Date of Death Information"
+4 WRITE !,?5,"Date of Death: ",$GET(PDTHINFO(2,DFN_",",.351,"E"))
+5 WRITE !,?5,"Source of Notification: ",$GET(PDTHINFO(2,DFN_",",.353,"E"))
+6 WRITE !,?5,"Updated Date/Time: ",$GET(PDTHINFO(2,DFN_",",.354,"E"))
+7 WRITE !,?5,"Last Edited By: ",$GET(PDTHINFO(2,DFN_",",.355,"E")),!
+8 IF $$OKLINE^DGRPD1(14)
DO EC^DGRPD1
+9 ;Y killed after dghinqky
KILL DGARRAY,SDCNT,^TMP($JOB,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I
+10 ;ihs/cmi/maw 06/18/2012 PATCH 1015 exists after call to EC^DGRPD1
KILL VAROOT
+11 QUIT
COV SET COV=$SELECT(+$PIECE(^TMP($JOB,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
+1 SET COV=COV_$SELECT(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:"")
SET CT=CT+1
QUIT
+2 QUIT
+3 ;
OREN SET XQORQUIT=1
IF '$DATA(ORVP)
QUIT
SET DFN=+ORVP
DO EN
READ !!,"Press RETURN to CONTINUE: ",X:DTIME
+1 QUIT
