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