RMIMU1.m

RMIMU1 ;WPB/JLTP ; FUNCTIONAL INDEPENDENCE UTILITIES CONT'D ; 30-AUG-2002

 ;;1.0;FUNCTIONAL INDEPENDENCE;;Apr 15, 2003

OF(IFN,VAL) ; File Other Fields

 N DA,DIE,DR,EDIT,FLD,I,II,LINE,LOC,X,Y

 S DR="" F LINE=1:1 S TEXT=$P($T(FLDS+LINE),";;",2) Q:TEXT=""  D

 .S FLD=$P(TEXT,U),LOC=$P(TEXT,U,2),SS=$P(LOC,","),LOC=$P(LOC,",",2)

 .I $P($G(VAL(SS)),U,LOC)="" Q

 .S EDIT=FLD_"///"_$P(VAL(SS),U,LOC)

 .I ($L(DR)+$L(EDIT))>200 D

 ..S DA=IFN,DIE="^RMIM(783," D ^DIE S DR=""

 .S:DR]"" DR=DR_";" S DR=DR_EDIT

 I DR]"" S DA=IFN,DIE="^RMIM(783," D ^DIE

 K ^RMIM(783,IFN,100) S I=9,II=0

 F  S I=$O(VAL(I)) Q:'I  S II=II+1,^RMIM(783,IFN,100,II,0)=VAL(I)

 S ^RMIM(783,IFN,100,0)="^783.01^"_II_U_II

 Q 1

GF(RMIMR) ; Retrieve Other Fields

 N FLD,GN,GP,LINE,N,P,X

 S IFN=+RMIMR(1)

 F LINE=1:1 S TEXT=$P($T(FLDS+LINE),";;",2) Q:TEXT=""  D

 .S FLD=$P(TEXT,U),P=$P(TEXT,U,2),N=$P(P,","),P=$P(P,",",2)

 .I +FLD=.16 S $P(RMIMR(N),U,12)=$P(^RMIM(783,IFN,0),U,16) Q

 .I +FLD=.17 S $P(RMIMR(N),U,13)=$P(^RMIM(783,IFN,0),U,17) Q

 .I FLD'=+FLD S $P(RMIMR(N),U,P)=$$GET1^DIQ(783,IFN,+FLD) Q

 .S X=$P(^DD(783,+FLD,0),U,4),GN=$P(X,";"),GP=$P(X,";",2)

 .S X=$P($G(^RMIM(783,IFN,GN)),U,GP)

 .I X S $P(RMIMR(N),U,P)=$$FMTE^XLFDT(X,5)

 S I=0,II=$O(RMIMR(""),-1)

 F  S I=$O(^RMIM(783,IFN,100,I)) Q:'I  S II=II+1,RMIMR(II)=^(I,0)

 Q

FLDS ;

 ;;.11^1,11

 ;;.16/^1,12

 ;;.17/^1,13

 ;;1.01/^2,1

 ;;1.02/^2,2

 ;;1.03/^2,3

 ;;1.04/^2,4

 ;;1.05/^2,5

 ;;1.06/^2,6

 ;;1.07/^2,7

 ;;1.08/^2,8

 ;;1.09/^2,9

 ;;2.01/^3,1

 ;;2.03/^3,3

 ;;2.04^3,4

 ;;2.05^3,5

 ;;2.06^3,6

 ;;2.07^3,7

 ;;2.08^3,8

 ;;2.09^3,9

 ;;2.1/^3,10

 ;;2.11/^3,11

 ;;3.01/^4,1

 ;;3.02/^4,2

 ;;3.03/^4,3

 ;;3.04/^4,4

 ;;3.05/^4,5

 ;;3.06/^4,6

 ;;3.07/^4,7

 ;;4.01/^5,1

 ;;4.02/^5,2

 ;;4.03/^5,3

 ;;4.04/^5,4

 ;;4.05/^5,5

 ;;4.06/^5,6

 ;;4.07/^5,7

 ;;4.08/^5,8

 ;;4.09/^5,9

 ;;4.1/^5,10

 ;;4.11/^5,11

 ;;4.12/^5,12

 ;;4.13/^5,13

 ;;4.14/^5,14

 ;;4.15/^5,15

 ;;4.16/^5,16

 ;;4.17/^5,17

 ;;4.18/^5,18

 ;;4.19/^5,19

 ;;4.2/^5,20

 ;;4.21/^5,21

 ;;5.01/^6,1

 ;;5.02/^6,2

 ;;5.03/^6,3

 ;;5.04/^6,4

 ;;5.05/^6,5

 ;;5.06/^6,6

 ;;5.07/^6,7

 ;;5.08/^6,8

 ;;5.09/^6,9

 ;;5.1/^6,10

 ;;5.11/^6,11

 ;;5.12/^6,12

 ;;5.13/^6,13

 ;;5.14/^6,14

 ;;5.15/^6,15

 ;;5.16/^6,16

 ;;5.17/^6,17

 ;;5.18/^6,18

 ;;5.19/^6,19

 ;;5.2/^6,20

 ;;5.21/^6,21

 ;;6.01/^7,1

 ;;6.02/^7,2

 ;;6.03/^7,3

 ;;6.04/^7,4

 ;;6.05/^7,5

 ;;6.06/^7,6

 ;;6.07/^7,7

 ;;6.08/^7,8

 ;;6.09/^7,9

 ;;6.1/^7,10

 ;;6.11/^7,11

 ;;6.12/^7,12

 ;;6.13/^7,13

 ;;6.14/^7,14

 ;;6.15/^7,15

 ;;6.16/^7,16

 ;;6.17/^7,17

 ;;6.18/^7,18

 ;;6.19/^7,19

 ;;6.2/^7,20

 ;;6.21/^7,21

 ;;7.01/^8,1

 ;;7.02/^8,2

 ;;7.03/^8,3

 ;;7.04/^8,4

 ;;7.05/^8,5

 ;;7.06/^8,6

 ;;7.07/^8,7

 ;;7.08/^8,8

 ;;7.09/^8,9

 ;;7.1/^8,10

 ;;7.11/^8,11

 ;;7.12/^8,12

 ;;7.13/^8,13

 ;;7.14/^8,14

 ;;7.15/^8,15

 ;;7.16/^8,16

 ;;7.17/^8,17

 ;;7.18/^8,18

 ;;7.19/^8,19

 ;;7.2/^8,20

 ;;7.21/^8,21

 ;;8.01/^9,1

 ;;8.02/^9,2

 ;;8.03/^9,3

 ;;8.04/^9,4

 ;;8.05/^9,5

 ;;8.06/^9,6

 ;;8.07/^9,7

 ;;8.08/^9,8

 ;;8.09/^9,9

 ;;8.1/^9,10

 ;;8.11/^9,11

 ;;8.12/^9,12

 ;;8.13/^9,13

 ;;8.14/^9,14

 ;;8.15/^9,15

 ;;8.16/^9,16

 ;;8.17/^9,17

 ;;8.18/^9,18

 ;;8.19/^9,19

 ;;8.2/^9,20

 ;;8.21/^9,21

 ;;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMIMU1   3258     printed  Mar 13, 2025@20:59:46                                                                                                                                                                                                      Page 2

RMIMU1    ;WPB/JLTP ; FUNCTIONAL INDEPENDENCE UTILITIES CONT'D ; 30-AUG-2002

 +1       ;;1.0;FUNCTIONAL INDEPENDENCE;;Apr 15, 2003

OF(IFN,VAL) ; File Other Fields

 +1        NEW DA,DIE,DR,EDIT,FLD,I,II,LINE,LOC,X,Y

 +2        SET DR=""

           FOR LINE=1:1

               SET TEXT=$PIECE($TEXT(FLDS+LINE),";;",2)

               if TEXT=""

                   QUIT 

               Begin DoDot:1

 +3                SET FLD=$PIECE(TEXT,U)

                   SET LOC=$PIECE(TEXT,U,2)

                   SET SS=$PIECE(LOC,",")

                   SET LOC=$PIECE(LOC,",",2)

 +4                IF $PIECE($GET(VAL(SS)),U,LOC)=""

                       QUIT 

 +5                SET EDIT=FLD_"///"_$PIECE(VAL(SS),U,LOC)

 +6                IF ($LENGTH(DR)+$LENGTH(EDIT))>200

                       Begin DoDot:2

 +7                        SET DA=IFN

                           SET DIE="^RMIM(783,"

                           DO ^DIE

                           SET DR=""

                       End DoDot:2

 +8                if DR]""

                       SET DR=DR_";"

                   SET DR=DR_EDIT

               End DoDot:1

 +9        IF DR]""

               SET DA=IFN

               SET DIE="^RMIM(783,"

               DO ^DIE

 +10       KILL ^RMIM(783,IFN,100)

           SET I=9

           SET II=0

 +11       FOR 

               SET I=$ORDER(VAL(I))

               if 'I

                   QUIT 

               SET II=II+1

               SET ^RMIM(783,IFN,100,II,0)=VAL(I)

 +12       SET ^RMIM(783,IFN,100,0)="^783.01^"_II_U_II

 +13       QUIT 1

GF(RMIMR) ; Retrieve Other Fields

 +1        NEW FLD,GN,GP,LINE,N,P,X

 +2        SET IFN=+RMIMR(1)

 +3        FOR LINE=1:1

               SET TEXT=$PIECE($TEXT(FLDS+LINE),";;",2)

               if TEXT=""

                   QUIT 

               Begin DoDot:1

 +4                SET FLD=$PIECE(TEXT,U)

                   SET P=$PIECE(TEXT,U,2)

                   SET N=$PIECE(P,",")

                   SET P=$PIECE(P,",",2)

 +5                IF +FLD=.16

                       SET $PIECE(RMIMR(N),U,12)=$PIECE(^RMIM(783,IFN,0),U,16)

                       QUIT 

 +6                IF +FLD=.17

                       SET $PIECE(RMIMR(N),U,13)=$PIECE(^RMIM(783,IFN,0),U,17)

                       QUIT 

 +7                IF FLD'=+FLD

                       SET $PIECE(RMIMR(N),U,P)=$$GET1^DIQ(783,IFN,+FLD)

                       QUIT 

 +8                SET X=$PIECE(^DD(783,+FLD,0),U,4)

                   SET GN=$PIECE(X,";")

                   SET GP=$PIECE(X,";",2)

 +9                SET X=$PIECE($GET(^RMIM(783,IFN,GN)),U,GP)

 +10               IF X

                       SET $PIECE(RMIMR(N),U,P)=$$FMTE^XLFDT(X,5)

               End DoDot:1

 +11       SET I=0

           SET II=$ORDER(RMIMR(""),-1)

 +12       FOR 

               SET I=$ORDER(^RMIM(783,IFN,100,I))

               if 'I

                   QUIT 

               SET II=II+1

               SET RMIMR(II)=^(I,0)

 +13       QUIT 

FLDS      ;

 +1       ;;.11^1,11

 +2       ;;.16/^1,12

 +3       ;;.17/^1,13

 +4       ;;1.01/^2,1

 +5       ;;1.02/^2,2

 +6       ;;1.03/^2,3

 +7       ;;1.04/^2,4

 +8       ;;1.05/^2,5

 +9       ;;1.06/^2,6

 +10      ;;1.07/^2,7

 +11      ;;1.08/^2,8

 +12      ;;1.09/^2,9

 +13      ;;2.01/^3,1

 +14      ;;2.03/^3,3

 +15      ;;2.04^3,4

 +16      ;;2.05^3,5

 +17      ;;2.06^3,6

 +18      ;;2.07^3,7

 +19      ;;2.08^3,8

 +20      ;;2.09^3,9

 +21      ;;2.1/^3,10

 +22      ;;2.11/^3,11

 +23      ;;3.01/^4,1

 +24      ;;3.02/^4,2

 +25      ;;3.03/^4,3

 +26      ;;3.04/^4,4

 +27      ;;3.05/^4,5

 +28      ;;3.06/^4,6

 +29      ;;3.07/^4,7

 +30      ;;4.01/^5,1

 +31      ;;4.02/^5,2

 +32      ;;4.03/^5,3

 +33      ;;4.04/^5,4

 +34      ;;4.05/^5,5

 +35      ;;4.06/^5,6

 +36      ;;4.07/^5,7

 +37      ;;4.08/^5,8

 +38      ;;4.09/^5,9

 +39      ;;4.1/^5,10

 +40      ;;4.11/^5,11

 +41      ;;4.12/^5,12

 +42      ;;4.13/^5,13

 +43      ;;4.14/^5,14

 +44      ;;4.15/^5,15

 +45      ;;4.16/^5,16

 +46      ;;4.17/^5,17

 +47      ;;4.18/^5,18

 +48      ;;4.19/^5,19

 +49      ;;4.2/^5,20

 +50      ;;4.21/^5,21

 +51      ;;5.01/^6,1

 +52      ;;5.02/^6,2

 +53      ;;5.03/^6,3

 +54      ;;5.04/^6,4

 +55      ;;5.05/^6,5

 +56      ;;5.06/^6,6

 +57      ;;5.07/^6,7

 +58      ;;5.08/^6,8

 +59      ;;5.09/^6,9

 +60      ;;5.1/^6,10

 +61      ;;5.11/^6,11

 +62      ;;5.12/^6,12

 +63      ;;5.13/^6,13

 +64      ;;5.14/^6,14

 +65      ;;5.15/^6,15

 +66      ;;5.16/^6,16

 +67      ;;5.17/^6,17

 +68      ;;5.18/^6,18

 +69      ;;5.19/^6,19

 +70      ;;5.2/^6,20

 +71      ;;5.21/^6,21

 +72      ;;6.01/^7,1

 +73      ;;6.02/^7,2

 +74      ;;6.03/^7,3

 +75      ;;6.04/^7,4

 +76      ;;6.05/^7,5

 +77      ;;6.06/^7,6

 +78      ;;6.07/^7,7

 +79      ;;6.08/^7,8

 +80      ;;6.09/^7,9

 +81      ;;6.1/^7,10

 +82      ;;6.11/^7,11

 +83      ;;6.12/^7,12

 +84      ;;6.13/^7,13

 +85      ;;6.14/^7,14

 +86      ;;6.15/^7,15

 +87      ;;6.16/^7,16

 +88      ;;6.17/^7,17

 +89      ;;6.18/^7,18

 +90      ;;6.19/^7,19

 +91      ;;6.2/^7,20

 +92      ;;6.21/^7,21

 +93      ;;7.01/^8,1

 +94      ;;7.02/^8,2

 +95      ;;7.03/^8,3

 +96      ;;7.04/^8,4

 +97      ;;7.05/^8,5

 +98      ;;7.06/^8,6

 +99      ;;7.07/^8,7

 +100     ;;7.08/^8,8

 +101     ;;7.09/^8,9

 +102     ;;7.1/^8,10

 +103     ;;7.11/^8,11

 +104     ;;7.12/^8,12

 +105     ;;7.13/^8,13

 +106     ;;7.14/^8,14

 +107     ;;7.15/^8,15

 +108     ;;7.16/^8,16

 +109     ;;7.17/^8,17

 +110     ;;7.18/^8,18

 +111     ;;7.19/^8,19

 +112     ;;7.2/^8,20

 +113     ;;7.21/^8,21

 +114     ;;8.01/^9,1

 +115     ;;8.02/^9,2

 +116     ;;8.03/^9,3

 +117     ;;8.04/^9,4

 +118     ;;8.05/^9,5

 +119     ;;8.06/^9,6

 +120     ;;8.07/^9,7

 +121     ;;8.08/^9,8

 +122     ;;8.09/^9,9

 +123     ;;8.1/^9,10

 +124     ;;8.11/^9,11

 +125     ;;8.12/^9,12

 +126     ;;8.13/^9,13

 +127     ;;8.14/^9,14

 +128     ;;8.15/^9,15

 +129     ;;8.16/^9,16

 +130     ;;8.17/^9,17

 +131     ;;8.18/^9,18

 +132     ;;8.19/^9,19

 +133     ;;8.2/^9,20

 +134     ;;8.21/^9,21

 +135     ;;