source: WorldVistAEHR/trunk/r/VISUAL_IMPAIRMENT_SERVICE_TEAM-ANRV/ANRVPR2.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.3 KB
RevLine 
[613]1ANRVPR2 ;AUG/JLTP - PRINT PATIENT RECORD CONT'D ; 30 Mar 98 / 7:47 am
2 ;;4.0; Visual Impairment Service Team ;;12 Jun 98
3GETDATA ;------ Gather Data into ANRV( array ------
4 D 6^VADPT ;K ANRV ;demographics & address
5 S (ANRV(1),PNM)=VADM(1),ANRV(2)=VAPA(1)
6 S ANRV(3)=$S(VAPA(4)]"":VAPA(4)_", ",1:"")_$S(+VAPA(5)>0:$P($G(^DIC(5,+VAPA(5),0)),U,2),1:"")_" "_VAPA(6)
7 S ANRV(4)=$P(VAPA(7),U,2),ANRV(5)=VAPA(8)
8 K VAPA S (ANRV(6),SSN)=$P(VADM(2),U,2),ANRV(10)=$P(VADM(3),U,2)
9 S (ANRV(12),AGE)=VADM(4),ANRV(13)=$P(VADM(10),U,2) ;K VADM
10 ;D ELIG^VADPT ;eligibility information
11 S ANRV(7)=VAEL(7),ANRV(9)=$P(VAEL(2),U,2) ;claim#, pos
12 S ANRVPS=$P(VAEL(2),U,2) ;K VAEL ;period of service
13 D SVC^VADPT ;service record
14 S ANRV(9)=ANRV(9)_$S($P(VASV(6,4),U,2)]"":" ("_$P(VASV(6,4),U,2),1:"")_$S($P(VASV(6,5),U,2)]"":" - "_$P(VASV(6,5),U,2)_")",1:"")
15 S ANRV(9.5)=$P(VASV(6,1),U,2) ;last branch of service
16 ;K VASV
17 D OPD^VADPT ;other patient data
18 S ANRV(11)=VAPD(1)_$S(+VAPD(2)>0:", "_$P($G(^DIC(5,+VAPD(2),0)),U,2),1:"")
19 S ANRV(12.5)=$P(VAPD(7),U,2) ;employment status
20 ;K VAPD
21 D KVAR^VADPT,KVA^VADPT
22OTHER ;------ Data not available from VADPT ------
23 S DIC="^DPT(",DA=DFN,DR=.314,DIQ="ANRV(" D EN^DIQ1
24 S ANRV(8)=ANRV(2,DFN,.314)
25 S ANRVFN=$O(^ANRV(2040,"B",DFN,0)) ;vist roster internal number
26 ;Living Arrangements
27 S Y=$P($G(^ANRV(2040,ANRVFN,7)),U,5),C=$P(^DD(2040,1.2,0),U,2) D Y^DIQ S ANRV(13.5)=Y
28 S ANRV(15)=$P($G(^ANRV(2040,ANRVFN,13)),U) ;spouse
29 S ANRV(17)=$P($G(^ANRV(2040,ANRVFN,2)),U) ;eligibility
30 K ANRV(17.1) S X=1 ;prepare to gather rated disabilities
31 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I D
32 .S Y=+$G(^DPT(DFN,.372,I,0)),Y(1)=$P(^(0),U,2)
33 .S Y(0)=$G(^DIC(31,Y,0))
34 .S Y=$S($P(Y(0),U,4)]"":$P(Y(0),U,4),1:$P(Y(0),U))
35 .I Y]"" D
36 ..S Y=Y_" ("_Y(1)_"%)"
37 ..S ANRV(17.1,X)=Y,X=X+1
38 S ANRV(14)=0 F I=0:0 S I=$O(^ANRV(2040,ANRVFN,1,I)) Q:'I D
39 .S ANRV(14)=ANRV(14)+1,ANRV(16,ANRV(14))=$P(^ANRV(2040,ANRVFN,1,I,0),U) ;dependants
40 S I=+$P($G(^ANRV(2040,ANRVFN,3,0)),U,3),ANRV(18)=$G(^(I,0)) ;last eye
41 S $P(ANRV(18),U)=$$DATE(+ANRV(18)) ;date of last eye exam
42 K ANRV(17.5) S X=1 ;Next we will gather all eye diagnoses
43 F I=0:0 S I=$O(^ANRV(2040,ANRVFN,15,I)) Q:'I S Y=+^(I,0) D
44 .S:$G(ANRV(17.5,X))]"" ANRV(17.5,X)=ANRV(17.5,X)_", "
45 .S X1=$P($G(^ANRV(2041.5,Y,0)),U)
46 .I ($L($G(ANRV(17.5,X)))+$L(X1)+31)>IOM S X=X+1
47 .S ANRV(17.5,X)=$G(ANRV(17.5,X))_X1
48 S I=+$P($G(^ANRV(2040,ANRVFN,6,0)),U,3),ANRV(19)=$G(^(I,0)) ;last
49 I I'=0 S $P(ANRV(19),U)=$$DATE(+ANRV(19)) ;vist review date
50 ;Type of Review
51 I I'=0 S Y=$P(ANRV(19),U,2),C=$P(^DD(2040.06,1,0),U,2) D Y^DIQ S $P(ANRV(19),"^",2)=Y
52 ;elegibility on review date
53 I I'=0 S Y=$P(ANRV(19),U,3),C=$P(^DD(2040.06,2,0),U,2) D Y^DIQ S $P(ANRV(19),"^",3)=Y
54ANRVZ I I=0 S ANRV(19)="^^^^^"
55 S I=+$P($G(^ANRV(2040,ANRVFN,10,0)),U,3),Y=$G(^(I,0)) ;last
56 S ANRV(20)=$$DATE(Y) ;field visit date
57 Q
58SET ;------ Resolve Set of Codes ------
59 Q
60INIT ;------ Set up headings, footers, etc ------
61 S ANRVPG=0
62 K ANRV,ANRVH,ANRVC S ANRVH(1)="VISUAL IMPAIRMENT SERVICE TEAM (VIST)"
63 S ANRVH(2)="PATIENT RECORD"
64 S ANRVSITE=$O(^ANRV(2041,0)),SITE=$P(^ANRV(2041,ANRVSITE,0),"^"),ANRVH(3)=$P(^DIC(4,SITE,0),"^")_" ("_$P(^DIC(4,SITE,99),"^")_")"
65 D NOW^%DTC S DT=X S ANRVH(4)=$$DATE(X)
66 S X=$G(^ANRV(2041,1,0)),ANRVC(1)=$P(X,U,2)
67 S ANRVC(2)="VIST Coordinator - "_$P(^ANRV(2041,ANRVSITE,0),U,3)
68 Q
69DATE(Y) ;------ Convert Y to external format ------
70 D DD^%DT Q Y
Note: See TracBrowser for help on using the repository browser.