source: FOIAVistA/trunk/r/FUNCTIONAL_INDEPENDENCE-RMIM/RMIMRP.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.4 KB
Line 
1RMIMRP ;WPB/JLTP ; FUNCTIONAL INDEPENDENCE RPCs ; 1/12/04 5:03pm
2 ;;1.0;FUNCTIONAL INDEPENDENCE;**3**;Apr 15, 2003
3PRM(RMIMR) ; Return Site Parameter Information
4 K RMIMR
5 N CNT,CNTI,FAC,FNT,FNTI,I,INST,MG,NFNT,NFNT,NT,STANUM,X
6 S RMIMR(1)="-1^Site Parameters Not Found"
7 S X=$G(^RMIM(783.9,1,0)) Q:X="" S INST=+X
8 S INST=$P($G(^DIC(4,INST,0)),U),STANUM=$P($G(^(99)),U)
9 S MG=$P($G(^XMB(3.8,+$P(X,U,3),0)),U)
10 S FNTI=+$P(X,U,4),NFNTI=+$P(X,U,5),CNTI=+$P(X,U,6)
11 S FNT=$P($G(^TIU(8925.1,FNTI,0)),U)
12 S NFNT=$P($G(^TIU(8925.1,NFNTI,0)),U)
13 S CNT=$P($G(^TIU(8925.1,CNTI,0)),U)
14 S NT=U_FNTI_U_FNT_U_NFNTI_U_NFNT_U_CNTI_U_CNT_U
15 S I=0,FAC=1 F S I=$O(^RMIM(783.9,1,10,I)) Q:'I S X=^(I,0) D
16 .S FAC=FAC+1,RMIMR(FAC)=X
17 S RMIMTIME=$S($G(^VA(200,DUZ,200)):$P(^(200),U,10),1:$G(DTIME))
18 S RMIMR(1)=INST_U_STANUM_U_MG_NT_(FAC-1)_U_RMIMTIME
19 Q
20DME(RMIMR,P1) ; DME for a Patient
21 K RMIMR
22 N DATE,DFN,IFN,ITM,ITM0,ITMI,RMIMAD,RMIMDC,TCST
23 I '$G(P1) S RMIMR(0)="-1^Missing Patient Identifier" Q
24 S DFN=+P1,RMIMAD=+$P(P1,U,2),RMIMDC=+$P(P1,U,3),RMIMR(0)=0
25 I 'RMIMAD!('RMIMDC) D Q
26 .S RMIMR(0)="-2^Missing Required Date Range"
27 S IFN=0 F S IFN=$O(^RMPR(664.1,"D",DFN,IFN)) Q:'IFN D
28 .S DATE=$P(^RMPR(664.1,IFN,0),U) Q:(DATE<RMIMAD)!(DATE>RMIMDC)
29 .S ITMI=0 F S ITMI=$O(^RMPR(664.1,IFN,2,ITMI)) Q:'ITMI D
30 ..S ITM0=$G(^RMPR(664.1,IFN,2,ITMI,0))
31 ..S ITM=+ITM0,TCST=$P(ITM0,U,11)
32 ..S ITM=+$G(^RMPR(661,ITM,0)),ITM=$P($G(^PRC(441,ITM,0)),U,2) I ITM]"" D
33 ...S RMIMR(0)=RMIMR(0)+1
34 ...S RMIMR(RMIMR(0))=ITM_U_TCST
35 Q
36DFN(RMIMR,SSN) ; Convert a Patient's SSN to Internal Entry Number
37 K RMIMR N C,DFN,I,X S X=$G(SSN),SSN=""
38 F I=1:1:$L(X) S C=$E(X,I) I "0123456789P"[C S SSN=SSN_C
39 I SSN'?9N.1"P" S RMIMR(1)="-1^Invalid SSN" Q
40 S DFN=$O(^DPT("SSN",SSN,0))
41 I 'DFN S RMIMR(1)="-2^SSN Not Found" Q
42 S RMIMR(1)=DFN
43 Q
44FRM(RMIMR,F) ; Set Form Title into Broker Partition
45 K RMIMR
46 S RMIMFORM=F_" "_$P(^RMIM(783.9,1,0),U,7),RMIMR(1)="1^OK"
47 Q
48DTFMT(RMIMR,X) ; Validate and Format External Date/Time
49 K RMIMR N %DT,Y
50 S %DT="TS" D ^%DT
51 I Y<0 S RMIMR(1)="-1^Invalid Date/Time" Q
52 S RMIMR(1)=$$FMTE^XLFDT(Y,5)
53 Q
54XM(RMIMR,X,RMIMTX) ; Send a MailMan Message
55 K RMIMR
56 N I,RECIP,REPLY,TEXT,XMDUN,XMDUZ,XMER,XMMG,XMSUB,XMTEXT,XMY,XMZ
57 S XMSUB=$P(X,U),RECIP=$P(X,U,2)
58 S:$G(^XMB(3.9,+$P(X,U,3),0))]"" REPLY=$P(X,U,3) S XMY(RECIP)=""
59 I '$O(RMIMTX(0))!(XMSUB="")!(RECIP="") D Q
60 .S RMIMR(1)="-1^Missing Subject, Text, or Recipients for Mail Message"
61 S I=0,X="" F S X=$O(RMIMTX(X)) Q:X="" S I=I+1,TEXT(I,0)=RMIMTX(X)
62 S XMTEXT="TEXT(" I '$G(REPLY) D ^XMD S:$D(XMMG) XMER=XMMG
63 I $G(REPLY) S X=$$ENT^XMA2R(REPLY,"",.TEXT) S XMZ=REPLY S:'X XMER=X
64 I $G(XMER) S RMIMR(1)="-1^"_XMER Q
65 S RMIMR(1)="1^"_XMZ
66 Q
67DUZ(RMIMR,X) ; Return NEW PERSON Information
68 K RMIMR N KEY
69 S X=+$G(X) S:'X X=DUZ S RMIMR(1)="-1^User Number Not Defined"
70 Q:'X S X=X_U_$P($G(^VA(200,+X,0)),U)
71 S KEY=$S($D(^XUSEC("RMIM COORD",+X)):2,$D(^XUSEC("RMIM FSOD",+X)):1,1:0)
72 S X=X_U_KEY,RMIMR(1)=X
73 Q
74SAV(RMIMR,RMIML) ; Save Information about a Case
75 N NXT,OP,X,Y
76 S NXT=$O(RMIML("")) I NXT="" S (RMIMR,RMIMR(1))=$$ERR^RMIMU(-4) Q
77 S OP=$P(RMIML(NXT),U),X=$P(RMIML(NXT),U,2,200)
78 S Y=$S(OP="A":$$A^RMIMU(X),OP="E":$$E^RMIMU(X),OP="D":$$D^RMIMU(X),1:0)
79 S:Y=0 Y=$$ERR^RMIMU(-5)
80 I OP'="D",Y>0 S Y=$$OF^RMIMU1(+Y,.RMIML)
81 S (RMIMR,RMIMR(1))=Y
82 Q
83LC(RMIMR,X) ; Returns a List of Cases from File #783
84 N DATE,DFN,FAC,I,IFN,Y
85 S IDX=1,DFN=+X,FAC=$P(X,U,2)
86 S IFN=0 F S IFN=$O(^RMIM(783,"DFN",DFN,IFN)) Q:'IFN D
87 .S X=$G(^RMIM(783,IFN,0)) Q:$P(X,U,6)'=FAC Q:$P(X,U,14)="D"
88 .S IDX=IDX+1,Y(IDX)=$P(X,U,2)_U_DFN_U_FAC
89 .F I=10,11 D
90 ..S DATE=$P(X,U,I) S:DATE]"" DATE=$$FMTE^XLFDT(DATE,5)
91 ..S Y(IDX)=Y(IDX)_U_DATE
92 S Y(1)=IDX-1 M RMIMR=Y
93 Q
94GC(RMIMR,X) ; Returns Information about a Specific Case
95 K RMIMR N CASE,I,IFN
96 S CASE=+$G(X) I 'CASE S RMIMR(1)=$$ERR^RMIMU(-1) Q
97 S (I,IFN)=0 F S I=$O(^RMIM(783,"CASE",CASE,I)) Q:'I D
98 .I $G(^RMIM(783,I,0))]"",$P(^(0),U,14)'="D" S IFN=I
99 I 'IFN S RMIMR(1)=$$ERR^RMIMU(-6) Q
100 S RMIMR(1)=IFN_U_CASE D GC^RMIMU(.RMIMR),GF^RMIMU1(.RMIMR)
101 Q
102PL(RMIMR,X) ; Patient Lookup
103 K RMIMR N I,SEN,SL,Y
104 D FIND^DIC(2,"","@;.01;.03I;.09","CMP",X,"","","","","Y")
105 S I=0 F S I=$O(Y("DILIST",I)) Q:'I S LI=Y("DILIST",I,0) D
106 .S $P(LI,U,6,7)=$P(LI,U,3,4)
107 .D PTSEC^DGSEC4(.SEN,+LI)
108 .I SEN(1) S $P(LI,U,3,5)="*SENSITIVE*^*SENSITIVE*^"_+SEN(1)
109 .S RMIMR(I)=LI
110 Q
111RRN(RMIMR,X) ; Send Restricted Record Access Notification
112 K RMIMR N Y
113 D NOTICE^DGSEC4(.Y,+X,"RMIM FIM^FIM GUI")
114 S RMIMR(1)=Y
115 Q
116AL(RMIMR,X) ; Author Lookup
117 K RMIMR N I,Y
118 D FIND^DIC(200,"","@;.01","CMP",X,"","","","","Y")
119 S I=0 F S I=$O(Y("DILIST",I)) Q:'I S RMIMR(I)=Y("DILIST",I,0)
120 Q
121LL(RMIMR,X) ; Location Lookup
122 K RMIMR N I,Y
123 D FIND^DIC(44,"","@;.01","CMP",X,"","","","","Y")
124 S I=0 F S I=$O(Y("DILIST",I)) Q:'I S RMIMR(I)=Y("DILIST",I,0)
125 Q
126PI(RMIMR,DFN) ; Patient Information
127 K RMIMR S RMIMR(1)=$$ERR^RMIMU(-8)
128 N I,VA,VADM,VAEL,VAERR,VAPA,X,Y
129 D DEM^VADPT Q:VAERR
130 D ADD^VADPT Q:VAERR
131 D ELIG^VADPT Q:VAERR
132 M X=VADM F I=8,10 S X(I)=$P(X(I),U,2)
133 I X(8)="" S:$D(VADM(12,1)) X(8)=$P(VADM(12,1),U,2) ;New Race Information Multiple
134 S Y=DFN F I=1,2,8,4,5,10 S Y=Y_U_$P(X(I),U)
135 S Y=Y_U_$S($P(VAEL(6),U,2)="ACTIVE DUTY":"A",1:"N")
136 K X M X=VAPA F I=5,7 S X(I)=$P(X(I),U,2)
137 F I=1,4,5,6,7,8 S Y=Y_U_$P(X(I),U)
138 S RMIMR(1)=Y
139 Q
140PTL(RMIMR,X) ; Lock/Unlock Patient
141 S X=$G(X),DFN=+X,L=+$P(X,U,2) I 'DFN S RMIMR(1)="-1^Invalid Patient" Q
142 I 'L L -^RMIM("PATIENT",DFN) S RMIMR(1)=1 Q
143 S RMIMR(1)=1 L +^RMIM("PATIENT",DFN):2 E S RMIMR(1)=-1
144 Q
Note: See TracBrowser for help on using the repository browser.