| 1 | DGRPD ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC-PATIENT INQUIRY (NEW) ; 3/9/06 11:17am
|
|---|
| 2 | ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703**;Aug 13, 1993
|
|---|
| 3 | ; *286* Newing variables X,Y in OKLINE subroutine
|
|---|
| 4 | ; *358* If a patient is on a domiciliary ward, don't display MEANS
|
|---|
| 5 | ; TEST required/Medication Copayment Exemption messages
|
|---|
| 6 | ; *436* If an inpatient is not on a domiciliary ward, don't display
|
|---|
| 7 | ; Medication Copayment Exemption message
|
|---|
| 8 | ; *545* Add death information near the remarks field
|
|---|
| 9 | ; *677* Added Emergency Response
|
|---|
| 10 | 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
|
|---|
| 11 | EN ;call to display patient inquiry - input DFN
|
|---|
| 12 | ;MPI/PD CHANGE
|
|---|
| 13 | S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))
|
|---|
| 14 | S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
|
|---|
| 15 | I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^")
|
|---|
| 16 | ;END MPI/PD CHANGE
|
|---|
| 17 | K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR F I=0,.11,.13,.121,.31,.32,.36,.361,.141,.3 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
|
|---|
| 18 | 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
|
|---|
| 19 | 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")
|
|---|
| 20 | S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) !?10 W:'(I#2) ?51 W DGA(I)
|
|---|
| 21 | 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) W !?2,"County: ",DGCC
|
|---|
| 22 | 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)
|
|---|
| 23 | W ?42,"From/To: ",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 DGTMPAD
|
|---|
| 24 | W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
|
|---|
| 25 | W !?4,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU)
|
|---|
| 26 | W !?2,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU)
|
|---|
| 27 | W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN))
|
|---|
| 28 | D CA
|
|---|
| 29 | N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^"))
|
|---|
| 30 | W:DGEMER]"" !?32,"Emergency Response: ",DGEMER
|
|---|
| 31 | 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")
|
|---|
| 32 | 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")
|
|---|
| 33 | I 'DGABBRV W ! D
|
|---|
| 34 | .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
|
|---|
| 35 | .K ^UTILITY($J,"W")
|
|---|
| 36 | .S PTR=0 F S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR D
|
|---|
| 37 | ..S VAL=+$G(^DPT(DFN,.02,PTR,0))
|
|---|
| 38 | ..Q:$$INACTIVE^DGUTL4(VAL,1)
|
|---|
| 39 | ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "
|
|---|
| 40 | ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
|
|---|
| 41 | .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"
|
|---|
| 42 | .K ^UTILITY($J,"W")
|
|---|
| 43 | .S PTR=0 F S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR D
|
|---|
| 44 | ..S VAL=+$G(^DPT(DFN,.06,PTR,0))
|
|---|
| 45 | ..Q:$$INACTIVE^DGUTL4(VAL,2)
|
|---|
| 46 | ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "
|
|---|
| 47 | ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
|
|---|
| 48 | .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"
|
|---|
| 49 | .K ^UTILITY($J,"W")
|
|---|
| 50 | .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
|
|---|
| 51 | .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0)) W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
|
|---|
| 52 | I '$$OKLINE(16) G Q
|
|---|
| 53 | ;display cv status #4156
|
|---|
| 54 | N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
|
|---|
| 55 | 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")
|
|---|
| 56 | ;display primary eligibility
|
|---|
| 57 | 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)
|
|---|
| 58 | 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
|
|---|
| 59 | I '$$OKLINE(16) G Q
|
|---|
| 60 | ;employability status
|
|---|
| 61 | W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO")
|
|---|
| 62 | ;display the catastrophic disability review date if there is one
|
|---|
| 63 | D CATDIS^DGRPD1
|
|---|
| 64 | I $G(DGPRFLG)=1 G Q:'$$OKLINE(19) D
|
|---|
| 65 | . N DGPDT,DGPTM
|
|---|
| 66 | . W !,$$REPEAT^XLFSTR("-",78)
|
|---|
| 67 | . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)
|
|---|
| 68 | . W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
|
|---|
| 69 | . S DGPTM=$$PCTEAM^DGSDUTL(DFN)
|
|---|
| 70 | . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)
|
|---|
| 71 | . W !,$$REPEAT^XLFSTR("-",78)
|
|---|
| 72 | ; Check if patient is an inpatient and on a DOM ward
|
|---|
| 73 | ; If inpatient is on a DOM ward, don't display MT or CP messages
|
|---|
| 74 | ; If inpatient is NOT on a DOM ward, don't display CP message
|
|---|
| 75 | N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
|
|---|
| 76 | G Q:'$$OKLINE(14)
|
|---|
| 77 | D DOM^DGMTR
|
|---|
| 78 | I '$G(DGDOM) D
|
|---|
| 79 | .D DIS^DGMTU(DFN)
|
|---|
| 80 | .D IN5^VADPT
|
|---|
| 81 | .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)
|
|---|
| 82 | ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
|
|---|
| 83 | D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518)
|
|---|
| 84 | S VAIP("L")=""
|
|---|
| 85 | I $$OKLINE(14) D INP
|
|---|
| 86 | I '$G(DGRPOUT),($$OKLINE(17)) D SA
|
|---|
| 87 | ;MPI/PD CHANGE
|
|---|
| 88 | 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
|
|---|
| 89 | CA ;Confidential Address
|
|---|
| 90 | W !!?1,"Confidential Address: ",?44,"Confidential Address Categories:"
|
|---|
| 91 | N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR
|
|---|
| 92 | S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)
|
|---|
| 93 | I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) D Q
|
|---|
| 94 | .W !?9,"NO CONFIDENTIAL ADDRESS"
|
|---|
| 95 | .W !?1,"From/To: NOT APPLICABLE"
|
|---|
| 96 | S DGAD=.141,(DGA1,DGA2)=1
|
|---|
| 97 | D AL^DGRPU(30)
|
|---|
| 98 | D GETS^DIQ(2,DFN,".141*,","E","DGARRAY","DGERROR")
|
|---|
| 99 | ;Format Confidential Address categories
|
|---|
| 100 | N DGIEN,DGCAST
|
|---|
| 101 | S DGIEN=0
|
|---|
| 102 | S DGA2=2
|
|---|
| 103 | F S DGIEN=$O(DGARRAY(2.141,DGIEN)) Q:'DGIEN D
|
|---|
| 104 | .S DGA(DGA2)=DGARRAY(2.141,DGIEN,.01,"E")
|
|---|
| 105 | .S DGCAST=DGARRAY(2.141,DGIEN,1,"E")
|
|---|
| 106 | .S DGA(DGA2)=DGA(DGA2)_"("_$S(DGCAST="YES":"Active",1:"Inactive")_")"
|
|---|
| 107 | .S DGA2=DGA2+2
|
|---|
| 108 | 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)
|
|---|
| 109 | W !?1,"From/To: ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED")
|
|---|
| 110 | Q
|
|---|
| 111 | HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
|
|---|
| 112 | ;MPI/PD CHANGE
|
|---|
| 113 | W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
|
|---|
| 114 | ;END MPI/PD CHANGE
|
|---|
| 115 | INP S VAIP("D")="L" D INP^DGPMV10
|
|---|
| 116 | S DGPMT=0
|
|---|
| 117 | D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
|
|---|
| 118 | 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(17) SAA Q:$G(DGRPOUT)
|
|---|
| 119 | Q
|
|---|
| 120 | SAA ;Scheduled Admit Data
|
|---|
| 121 | W !!?14,"Scheduled Admit"
|
|---|
| 122 | W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)
|
|---|
| 123 | W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)
|
|---|
| 124 | W " on "_$$FMTE^XLFDT(L,"5DZ")
|
|---|
| 125 | Q ;SAA
|
|---|
| 126 | ;
|
|---|
| 127 | 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:"")
|
|---|
| 128 | ;
|
|---|
| 129 | FA G:'$$OKLINE(20) RMK
|
|---|
| 130 | ;
|
|---|
| 131 | N DGARRAY,SDCNT
|
|---|
| 132 | S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
|
|---|
| 133 | S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: "
|
|---|
| 134 | ;if there is lower subscripts hanging from the 101 node,
|
|---|
| 135 | ;then it is a valid appointment, otherwise it is
|
|---|
| 136 | ;an error eg 01/20/2005
|
|---|
| 137 | I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK
|
|---|
| 138 | I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK
|
|---|
| 139 | ;
|
|---|
| 140 | W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
|
|---|
| 141 | F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D Q:CT>5
|
|---|
| 142 | .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";")
|
|---|
| 143 | .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D
|
|---|
| 144 | ..D COV
|
|---|
| 145 | ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")
|
|---|
| 146 | ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2)
|
|---|
| 147 | ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
|
|---|
| 148 | ..Q
|
|---|
| 149 | I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments."
|
|---|
| 150 | RMK I '$G(DGRPOUT),($$OKLINE(21)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10)
|
|---|
| 151 | D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
|
|---|
| 152 | W !!
|
|---|
| 153 | W "Date of Death Information"
|
|---|
| 154 | W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
|
|---|
| 155 | W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
|
|---|
| 156 | W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
|
|---|
| 157 | W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
|
|---|
| 158 | I $$OKLINE(14) D EC^DGRPD1
|
|---|
| 159 | K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
|
|---|
| 160 | Q
|
|---|
| 161 | COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
|
|---|
| 162 | S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q
|
|---|
| 163 | Q
|
|---|
| 164 | ;
|
|---|
| 165 | OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
|
|---|
| 166 | Q
|
|---|
| 167 | OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE
|
|---|
| 168 | ;
|
|---|
| 169 | ;IN: DGLINE --MAX LINE COUNT W/O PAUSE
|
|---|
| 170 | ;OUT: DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW
|
|---|
| 171 | ; DGRPOUT[SET] -- 1 IF "
|
|---|
| 172 | N X,Y ;**286** MLR 09/25/00 Newing X & Y variables prior to ^DIR
|
|---|
| 173 | I $G(IOST)["P-" Q DGLINE ; if printer, quit
|
|---|
| 174 | I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0
|
|---|
| 175 | Q DGLINE
|
|---|
| 176 | ;
|
|---|
