RMIMRP.m

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 ---RMIMRP   5630     printed  Feb 18, 2025@23:21:27                                                                                                                                                                                                      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