RMIMRP ;WPB/JLTP ; FUNCTIONAL INDEPENDENCE RPCs ; 1/12/04 5:03pm
;;1.0;FUNCTIONAL INDEPENDENCE;**3**;Apr 15, 2003
PRM(RMIMR) ; Return Site Parameter Information
K RMIMR
N CNT,CNTI,FAC,FNT,FNTI,I,INST,MG,NFNT,NFNT,NT,STANUM,X
S RMIMR(1)="-1^Site Parameters Not Found"
S X=$G(^RMIM(783.9,1,0)) Q:X="" S INST=+X
S INST=$P($G(^DIC(4,INST,0)),U),STANUM=$P($G(^(99)),U)
S MG=$P($G(^XMB(3.8,+$P(X,U,3),0)),U)
S FNTI=+$P(X,U,4),NFNTI=+$P(X,U,5),CNTI=+$P(X,U,6)
S FNT=$P($G(^TIU(8925.1,FNTI,0)),U)
S NFNT=$P($G(^TIU(8925.1,NFNTI,0)),U)
S CNT=$P($G(^TIU(8925.1,CNTI,0)),U)
S NT=U_FNTI_U_FNT_U_NFNTI_U_NFNT_U_CNTI_U_CNT_U
S I=0,FAC=1 F S I=$O(^RMIM(783.9,1,10,I)) Q:'I S X=^(I,0) D
.S FAC=FAC+1,RMIMR(FAC)=X
S RMIMTIME=$S($G(^VA(200,DUZ,200)):$P(^(200),U,10),1:$G(DTIME))
S RMIMR(1)=INST_U_STANUM_U_MG_NT_(FAC-1)_U_RMIMTIME
Q
DME(RMIMR,P1) ; DME for a Patient
K RMIMR
N DATE,DFN,IFN,ITM,ITM0,ITMI,RMIMAD,RMIMDC,TCST
I '$G(P1) S RMIMR(0)="-1^Missing Patient Identifier" Q
S DFN=+P1,RMIMAD=+$P(P1,U,2),RMIMDC=+$P(P1,U,3),RMIMR(0)=0
I 'RMIMAD!('RMIMDC) D Q
.S RMIMR(0)="-2^Missing Required Date Range"
S IFN=0 F S IFN=$O(^RMPR(664.1,"D",DFN,IFN)) Q:'IFN D
.S DATE=$P(^RMPR(664.1,IFN,0),U) Q:(DATE<RMIMAD)!(DATE>RMIMDC)
.S ITMI=0 F S ITMI=$O(^RMPR(664.1,IFN,2,ITMI)) Q:'ITMI D
..S ITM0=$G(^RMPR(664.1,IFN,2,ITMI,0))
..S ITM=+ITM0,TCST=$P(ITM0,U,11)
..S ITM=+$G(^RMPR(661,ITM,0)),ITM=$P($G(^PRC(441,ITM,0)),U,2) I ITM]"" D
...S RMIMR(0)=RMIMR(0)+1
...S RMIMR(RMIMR(0))=ITM_U_TCST
Q
DFN(RMIMR,SSN) ; Convert a Patient's SSN to Internal Entry Number
K RMIMR N C,DFN,I,X S X=$G(SSN),SSN=""
F I=1:1:$L(X) S C=$E(X,I) I "0123456789P"[C S SSN=SSN_C
I SSN'?9N.1"P" S RMIMR(1)="-1^Invalid SSN" Q
S DFN=$O(^DPT("SSN",SSN,0))
I 'DFN S RMIMR(1)="-2^SSN Not Found" Q
S RMIMR(1)=DFN
Q
FRM(RMIMR,F) ; Set Form Title into Broker Partition
K RMIMR
S RMIMFORM=F_" "_$P(^RMIM(783.9,1,0),U,7),RMIMR(1)="1^OK"
Q
DTFMT(RMIMR,X) ; Validate and Format External Date/Time
K RMIMR N %DT,Y
S %DT="TS" D ^%DT
I Y<0 S RMIMR(1)="-1^Invalid Date/Time" Q
S RMIMR(1)=$$FMTE^XLFDT(Y,5)
Q
XM(RMIMR,X,RMIMTX) ; Send a MailMan Message
K RMIMR
N I,RECIP,REPLY,TEXT,XMDUN,XMDUZ,XMER,XMMG,XMSUB,XMTEXT,XMY,XMZ
S XMSUB=$P(X,U),RECIP=$P(X,U,2)
S:$G(^XMB(3.9,+$P(X,U,3),0))]"" REPLY=$P(X,U,3) S XMY(RECIP)=""
I '$O(RMIMTX(0))!(XMSUB="")!(RECIP="") D Q
.S RMIMR(1)="-1^Missing Subject, Text, or Recipients for Mail Message"
S I=0,X="" F S X=$O(RMIMTX(X)) Q:X="" S I=I+1,TEXT(I,0)=RMIMTX(X)
S XMTEXT="TEXT(" I '$G(REPLY) D ^XMD S:$D(XMMG) XMER=XMMG
I $G(REPLY) S X=$$ENT^XMA2R(REPLY,"",.TEXT) S XMZ=REPLY S:'X XMER=X
I $G(XMER) S RMIMR(1)="-1^"_XMER Q
S RMIMR(1)="1^"_XMZ
Q
DUZ(RMIMR,X) ; Return NEW PERSON Information
K RMIMR N KEY
S X=+$G(X) S:'X X=DUZ S RMIMR(1)="-1^User Number Not Defined"
Q:'X S X=X_U_$P($G(^VA(200,+X,0)),U)
S KEY=$S($D(^XUSEC("RMIM COORD",+X)):2,$D(^XUSEC("RMIM FSOD",+X)):1,1:0)
S X=X_U_KEY,RMIMR(1)=X
Q
SAV(RMIMR,RMIML) ; Save Information about a Case
N NXT,OP,X,Y
S NXT=$O(RMIML("")) I NXT="" S (RMIMR,RMIMR(1))=$$ERR^RMIMU(-4) Q
S OP=$P(RMIML(NXT),U),X=$P(RMIML(NXT),U,2,200)
S Y=$S(OP="A":$$A^RMIMU(X),OP="E":$$E^RMIMU(X),OP="D":$$D^RMIMU(X),1:0)
S:Y=0 Y=$$ERR^RMIMU(-5)
I OP'="D",Y>0 S Y=$$OF^RMIMU1(+Y,.RMIML)
S (RMIMR,RMIMR(1))=Y
Q
LC(RMIMR,X) ; Returns a List of Cases from File #783
N DATE,DFN,FAC,I,IFN,Y
S IDX=1,DFN=+X,FAC=$P(X,U,2)
S IFN=0 F S IFN=$O(^RMIM(783,"DFN",DFN,IFN)) Q:'IFN D
.S X=$G(^RMIM(783,IFN,0)) Q:$P(X,U,6)'=FAC Q:$P(X,U,14)="D"
.S IDX=IDX+1,Y(IDX)=$P(X,U,2)_U_DFN_U_FAC
.F I=10,11 D
..S DATE=$P(X,U,I) S:DATE]"" DATE=$$FMTE^XLFDT(DATE,5)
..S Y(IDX)=Y(IDX)_U_DATE
S Y(1)=IDX-1 M RMIMR=Y
Q
GC(RMIMR,X) ; Returns Information about a Specific Case
K RMIMR N CASE,I,IFN
S CASE=+$G(X) I 'CASE S RMIMR(1)=$$ERR^RMIMU(-1) Q
S (I,IFN)=0 F S I=$O(^RMIM(783,"CASE",CASE,I)) Q:'I D
.I $G(^RMIM(783,I,0))]"",$P(^(0),U,14)'="D" S IFN=I
I 'IFN S RMIMR(1)=$$ERR^RMIMU(-6) Q
S RMIMR(1)=IFN_U_CASE D GC^RMIMU(.RMIMR),GF^RMIMU1(.RMIMR)
Q
PL(RMIMR,X) ; Patient Lookup
K RMIMR N I,SEN,SL,Y
D FIND^DIC(2,"","@;.01;.03I;.09","CMP",X,"","","","","Y")
S I=0 F S I=$O(Y("DILIST",I)) Q:'I S LI=Y("DILIST",I,0) D
.S $P(LI,U,6,7)=$P(LI,U,3,4)
.D PTSEC^DGSEC4(.SEN,+LI)
.I SEN(1) S $P(LI,U,3,5)="*SENSITIVE*^*SENSITIVE*^"_+SEN(1)
.S RMIMR(I)=LI
Q
RRN(RMIMR,X) ; Send Restricted Record Access Notification
K RMIMR N Y
D NOTICE^DGSEC4(.Y,+X,"RMIM FIM^FIM GUI")
S RMIMR(1)=Y
Q
AL(RMIMR,X) ; Author Lookup
K RMIMR N I,Y
D FIND^DIC(200,"","@;.01","CMP",X,"","","","","Y")
S I=0 F S I=$O(Y("DILIST",I)) Q:'I S RMIMR(I)=Y("DILIST",I,0)
Q
LL(RMIMR,X) ; Location Lookup
K RMIMR N I,Y
D FIND^DIC(44,"","@;.01","CMP",X,"","","","","Y")
S I=0 F S I=$O(Y("DILIST",I)) Q:'I S RMIMR(I)=Y("DILIST",I,0)
Q
PI(RMIMR,DFN) ; Patient Information
K RMIMR S RMIMR(1)=$$ERR^RMIMU(-8)
N I,VA,VADM,VAEL,VAERR,VAPA,X,Y
D DEM^VADPT Q:VAERR
D ADD^VADPT Q:VAERR
D ELIG^VADPT Q:VAERR
M X=VADM F I=8,10 S X(I)=$P(X(I),U,2)
I X(8)="" S:$D(VADM(12,1)) X(8)=$P(VADM(12,1),U,2) ;New Race Information Multiple
S Y=DFN F I=1,2,8,4,5,10 S Y=Y_U_$P(X(I),U)
S Y=Y_U_$S($P(VAEL(6),U,2)="ACTIVE DUTY":"A",1:"N")
K X M X=VAPA F I=5,7 S X(I)=$P(X(I),U,2)
F I=1,4,5,6,7,8 S Y=Y_U_$P(X(I),U)
S RMIMR(1)=Y
Q
PTL(RMIMR,X) ; Lock/Unlock Patient
S X=$G(X),DFN=+X,L=+$P(X,U,2) I 'DFN S RMIMR(1)="-1^Invalid Patient" Q
I 'L L -^RMIM("PATIENT",DFN) S RMIMR(1)=1 Q
S RMIMR(1)=1 L +^RMIM("PATIENT",DFN):2 E S RMIMR(1)=-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMIMRP 5630 printed Nov 22, 2024@17:05:14 Page 2
RMIMRP ;WPB/JLTP ; FUNCTIONAL INDEPENDENCE RPCs ; 1/12/04 5:03pm
+1 ;;1.0;FUNCTIONAL INDEPENDENCE;**3**;Apr 15, 2003
PRM(RMIMR) ; Return Site Parameter Information
+1 KILL RMIMR
+2 NEW CNT,CNTI,FAC,FNT,FNTI,I,INST,MG,NFNT,NFNT,NT,STANUM,X
+3 SET RMIMR(1)="-1^Site Parameters Not Found"
+4 SET X=$GET(^RMIM(783.9,1,0))
if X=""
QUIT
SET INST=+X
+5 SET INST=$PIECE($GET(^DIC(4,INST,0)),U)
SET STANUM=$PIECE($GET(^(99)),U)
+6 SET MG=$PIECE($GET(^XMB(3.8,+$PIECE(X,U,3),0)),U)
+7 SET FNTI=+$PIECE(X,U,4)
SET NFNTI=+$PIECE(X,U,5)
SET CNTI=+$PIECE(X,U,6)
+8 SET FNT=$PIECE($GET(^TIU(8925.1,FNTI,0)),U)
+9 SET NFNT=$PIECE($GET(^TIU(8925.1,NFNTI,0)),U)
+10 SET CNT=$PIECE($GET(^TIU(8925.1,CNTI,0)),U)
+11 SET NT=U_FNTI_U_FNT_U_NFNTI_U_NFNT_U_CNTI_U_CNT_U
+12 SET I=0
SET FAC=1
FOR
SET I=$ORDER(^RMIM(783.9,1,10,I))
if 'I
QUIT
SET X=^(I,0)
Begin DoDot:1
+13 SET FAC=FAC+1
SET RMIMR(FAC)=X
End DoDot:1
+14 SET RMIMTIME=$SELECT($GET(^VA(200,DUZ,200)):$PIECE(^(200),U,10),1:$GET(DTIME))
+15 SET RMIMR(1)=INST_U_STANUM_U_MG_NT_(FAC-1)_U_RMIMTIME
+16 QUIT
DME(RMIMR,P1) ; DME for a Patient
+1 KILL RMIMR
+2 NEW DATE,DFN,IFN,ITM,ITM0,ITMI,RMIMAD,RMIMDC,TCST
+3 IF '$GET(P1)
SET RMIMR(0)="-1^Missing Patient Identifier"
QUIT
+4 SET DFN=+P1
SET RMIMAD=+$PIECE(P1,U,2)
SET RMIMDC=+$PIECE(P1,U,3)
SET RMIMR(0)=0
+5 IF 'RMIMAD!('RMIMDC)
Begin DoDot:1
+6 SET RMIMR(0)="-2^Missing Required Date Range"
End DoDot:1
QUIT
+7 SET IFN=0
FOR
SET IFN=$ORDER(^RMPR(664.1,"D",DFN,IFN))
if 'IFN
QUIT
Begin DoDot:1
+8 SET DATE=$PIECE(^RMPR(664.1,IFN,0),U)
if (DATE<RMIMAD)!(DATE>RMIMDC)
QUIT
+9 SET ITMI=0
FOR
SET ITMI=$ORDER(^RMPR(664.1,IFN,2,ITMI))
if 'ITMI
QUIT
Begin DoDot:2
+10 SET ITM0=$GET(^RMPR(664.1,IFN,2,ITMI,0))
+11 SET ITM=+ITM0
SET TCST=$PIECE(ITM0,U,11)
+12 SET ITM=+$GET(^RMPR(661,ITM,0))
SET ITM=$PIECE($GET(^PRC(441,ITM,0)),U,2)
IF ITM]""
Begin DoDot:3
+13 SET RMIMR(0)=RMIMR(0)+1
+14 SET RMIMR(RMIMR(0))=ITM_U_TCST
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
DFN(RMIMR,SSN) ; Convert a Patient's SSN to Internal Entry Number
+1 KILL RMIMR
NEW C,DFN,I,X
SET X=$GET(SSN)
SET SSN=""
+2 FOR I=1:1:$LENGTH(X)
SET C=$EXTRACT(X,I)
IF "0123456789P"[C
SET SSN=SSN_C
+3 IF SSN'?9N.1"P"
SET RMIMR(1)="-1^Invalid SSN"
QUIT
+4 SET DFN=$ORDER(^DPT("SSN",SSN,0))
+5 IF 'DFN
SET RMIMR(1)="-2^SSN Not Found"
QUIT
+6 SET RMIMR(1)=DFN
+7 QUIT
FRM(RMIMR,F) ; Set Form Title into Broker Partition
+1 KILL RMIMR
+2 SET RMIMFORM=F_" "_$PIECE(^RMIM(783.9,1,0),U,7)
SET RMIMR(1)="1^OK"
+3 QUIT
DTFMT(RMIMR,X) ; Validate and Format External Date/Time
+1 KILL RMIMR
NEW %DT,Y
+2 SET %DT="TS"
DO ^%DT
+3 IF Y<0
SET RMIMR(1)="-1^Invalid Date/Time"
QUIT
+4 SET RMIMR(1)=$$FMTE^XLFDT(Y,5)
+5 QUIT
XM(RMIMR,X,RMIMTX) ; Send a MailMan Message
+1 KILL RMIMR
+2 NEW I,RECIP,REPLY,TEXT,XMDUN,XMDUZ,XMER,XMMG,XMSUB,XMTEXT,XMY,XMZ
+3 SET XMSUB=$PIECE(X,U)
SET RECIP=$PIECE(X,U,2)
+4 if $GET(^XMB(3.9,+$PIECE(X,U,3),0))]""
SET REPLY=$PIECE(X,U,3)
SET XMY(RECIP)=""
+5 IF '$ORDER(RMIMTX(0))!(XMSUB="")!(RECIP="")
Begin DoDot:1
+6 SET RMIMR(1)="-1^Missing Subject, Text, or Recipients for Mail Message"
End DoDot:1
QUIT
+7 SET I=0
SET X=""
FOR
SET X=$ORDER(RMIMTX(X))
if X=""
QUIT
SET I=I+1
SET TEXT(I,0)=RMIMTX(X)
+8 SET XMTEXT="TEXT("
IF '$GET(REPLY)
DO ^XMD
if $DATA(XMMG)
SET XMER=XMMG
+9 IF $GET(REPLY)
SET X=$$ENT^XMA2R(REPLY,"",.TEXT)
SET XMZ=REPLY
if 'X
SET XMER=X
+10 IF $GET(XMER)
SET RMIMR(1)="-1^"_XMER
QUIT
+11 SET RMIMR(1)="1^"_XMZ
+12 QUIT
DUZ(RMIMR,X) ; Return NEW PERSON Information
+1 KILL RMIMR
NEW KEY
+2 SET X=+$GET(X)
if 'X
SET X=DUZ
SET RMIMR(1)="-1^User Number Not Defined"
+3 if 'X
QUIT
SET X=X_U_$PIECE($GET(^VA(200,+X,0)),U)
+4 SET KEY=$SELECT($DATA(^XUSEC("RMIM COORD",+X)):2,$DATA(^XUSEC("RMIM FSOD",+X)):1,1:0)
+5 SET X=X_U_KEY
SET RMIMR(1)=X
+6 QUIT
SAV(RMIMR,RMIML) ; Save Information about a Case
+1 NEW NXT,OP,X,Y
+2 SET NXT=$ORDER(RMIML(""))
IF NXT=""
SET (RMIMR,RMIMR(1))=$$ERR^RMIMU(-4)
QUIT
+3 SET OP=$PIECE(RMIML(NXT),U)
SET X=$PIECE(RMIML(NXT),U,2,200)
+4 SET Y=$SELECT(OP="A":$$A^RMIMU(X),OP="E":$$E^RMIMU(X),OP="D":$$D^RMIMU(X),1:0)
+5 if Y=0
SET Y=$$ERR^RMIMU(-5)
+6 IF OP'="D"
IF Y>0
SET Y=$$OF^RMIMU1(+Y,.RMIML)
+7 SET (RMIMR,RMIMR(1))=Y
+8 QUIT
LC(RMIMR,X) ; Returns a List of Cases from File #783
+1 NEW DATE,DFN,FAC,I,IFN,Y
+2 SET IDX=1
SET DFN=+X
SET FAC=$PIECE(X,U,2)
+3 SET IFN=0
FOR
SET IFN=$ORDER(^RMIM(783,"DFN",DFN,IFN))
if 'IFN
QUIT
Begin DoDot:1
+4 SET X=$GET(^RMIM(783,IFN,0))
if $PIECE(X,U,6)'=FAC
QUIT
if $PIECE(X,U,14)="D"
QUIT
+5 SET IDX=IDX+1
SET Y(IDX)=$PIECE(X,U,2)_U_DFN_U_FAC
+6 FOR I=10,11
Begin DoDot:2
+7 SET DATE=$PIECE(X,U,I)
if DATE]""
SET DATE=$$FMTE^XLFDT(DATE,5)
+8 SET Y(IDX)=Y(IDX)_U_DATE
End DoDot:2
End DoDot:1
+9 SET Y(1)=IDX-1
MERGE RMIMR=Y
+10 QUIT
GC(RMIMR,X) ; Returns Information about a Specific Case
+1 KILL RMIMR
NEW CASE,I,IFN
+2 SET CASE=+$GET(X)
IF 'CASE
SET RMIMR(1)=$$ERR^RMIMU(-1)
QUIT
+3 SET (I,IFN)=0
FOR
SET I=$ORDER(^RMIM(783,"CASE",CASE,I))
if 'I
QUIT
Begin DoDot:1
+4 IF $GET(^RMIM(783,I,0))]""
IF $PIECE(^(0),U,14)'="D"
SET IFN=I
End DoDot:1
+5 IF 'IFN
SET RMIMR(1)=$$ERR^RMIMU(-6)
QUIT
+6 SET RMIMR(1)=IFN_U_CASE
DO GC^RMIMU(.RMIMR)
DO GF^RMIMU1(.RMIMR)
+7 QUIT
PL(RMIMR,X) ; Patient Lookup
+1 KILL RMIMR
NEW I,SEN,SL,Y
+2 DO FIND^DIC(2,"","@;.01;.03I;.09","CMP",X,"","","","","Y")
+3 SET I=0
FOR
SET I=$ORDER(Y("DILIST",I))
if 'I
QUIT
SET LI=Y("DILIST",I,0)
Begin DoDot:1
+4 SET $PIECE(LI,U,6,7)=$PIECE(LI,U,3,4)
+5 DO PTSEC^DGSEC4(.SEN,+LI)
+6 IF SEN(1)
SET $PIECE(LI,U,3,5)="*SENSITIVE*^*SENSITIVE*^"_+SEN(1)
+7 SET RMIMR(I)=LI
End DoDot:1
+8 QUIT
RRN(RMIMR,X) ; Send Restricted Record Access Notification
+1 KILL RMIMR
NEW Y
+2 DO NOTICE^DGSEC4(.Y,+X,"RMIM FIM^FIM GUI")
+3 SET RMIMR(1)=Y
+4 QUIT
AL(RMIMR,X) ; Author Lookup
+1 KILL RMIMR
NEW I,Y
+2 DO FIND^DIC(200,"","@;.01","CMP",X,"","","","","Y")
+3 SET I=0
FOR
SET I=$ORDER(Y("DILIST",I))
if 'I
QUIT
SET RMIMR(I)=Y("DILIST",I,0)
+4 QUIT
LL(RMIMR,X) ; Location Lookup
+1 KILL RMIMR
NEW I,Y
+2 DO FIND^DIC(44,"","@;.01","CMP",X,"","","","","Y")
+3 SET I=0
FOR
SET I=$ORDER(Y("DILIST",I))
if 'I
QUIT
SET RMIMR(I)=Y("DILIST",I,0)
+4 QUIT
PI(RMIMR,DFN) ; Patient Information
+1 KILL RMIMR
SET RMIMR(1)=$$ERR^RMIMU(-8)
+2 NEW I,VA,VADM,VAEL,VAERR,VAPA,X,Y
+3 DO DEM^VADPT
if VAERR
QUIT
+4 DO ADD^VADPT
if VAERR
QUIT
+5 DO ELIG^VADPT
if VAERR
QUIT
+6 MERGE X=VADM
FOR I=8,10
SET X(I)=$PIECE(X(I),U,2)
+7 ;New Race Information Multiple
IF X(8)=""
if $DATA(VADM(12,1))
SET X(8)=$PIECE(VADM(12,1),U,2)
+8 SET Y=DFN
FOR I=1,2,8,4,5,10
SET Y=Y_U_$PIECE(X(I),U)
+9 SET Y=Y_U_$SELECT($PIECE(VAEL(6),U,2)="ACTIVE DUTY":"A",1:"N")
+10 KILL X
MERGE X=VAPA
FOR I=5,7
SET X(I)=$PIECE(X(I),U,2)
+11 FOR I=1,4,5,6,7,8
SET Y=Y_U_$PIECE(X(I),U)
+12 SET RMIMR(1)=Y
+13 QUIT
PTL(RMIMR,X) ; Lock/Unlock Patient
+1 SET X=$GET(X)
SET DFN=+X
SET L=+$PIECE(X,U,2)
IF 'DFN
SET RMIMR(1)="-1^Invalid Patient"
QUIT
+2 IF 'L
LOCK -^RMIM("PATIENT",DFN)
SET RMIMR(1)=1
QUIT
+3 SET RMIMR(1)=1
LOCK +^RMIM("PATIENT",DFN):2
IF '$TEST
SET RMIMR(1)=-1
+4 QUIT
