Routine: VPRDRMIM

VPRDRMIM ;SLC/MKB -- FIM extract ;8/2/11  15:29

 ;;1.0;VIRTUAL PATIENT RECORD;**5**;Sep 01, 2011;Build 21

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ; External References          DBIA#

 ; -------------------          -----

 ; %DT                          10003

 ; DIQ                           2056

 ; RMIMRP                        4745

 ; ------------ Get FIM cases from VistA ------------

EN(DFN,BEG,END,MAX,IFN) ; -- find patient's FIM cases

 N VPRSITE,VPRS,VPRN,VPRY,ADM,VPRITM,VPRCNT

 D PRM^RMIMRP(.VPRSITE) Q:'$O(VPRSITE(1))

 ; get one case

 I $G(IFN) D EN1(IFN,.VPRITM),XML(.VPRITM) G ENQ

 ; get all patient FIM cases

 S DFN=+$G(DFN) Q:DFN<1

 S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999),VPRCNT=0

 S VPRS=1 F  S VPRS=$O(VPRSITE(VPRS)) Q:VPRS<1  D

 . S VPRN=DFN_U_VPRSITE(VPRS)

 . D LC^RMIMRP(.VPRY,VPRN) Q:VPRY(1)<1

 . S VPRN=1 F  S VPRN=$O(VPRY(VPRN)) Q:(VPRN<1)!(VPRCNT'<MAX)  D

 .. S ADM=$$DATE($P(VPRY(VPRN),U,4)) Q:ADM<BEG  Q:ADM>END

 .. K VPRITM D EN1(+VPRY(VPRN),.VPRITM),XML(.VPRITM)

 .. S VPRCNT=VPRCNT+1

ENQ ;done

EN1(ID,FIM) ; -- return a case in FIM("attribute")=value

 N VPRM,X,I,TYPE,MOTOR,COGNTV K FIM

 S ID=+$G(ID) Q:ID<1  ;invalid ien

 D GC^RMIMRP(.VPRM,ID)

 S FIM("id")=ID,FIM("name")="Functional Independence Measurement"

 S FIM("facility")=$P(VPRSITE(1),U,2)_U_$P(VPRSITE(1),U) ;local stn#^name

 S X=$G(VPRM(1)),FIM("case")=$P(X,U,2)

 S FIM("care")=$P(X,U,7),FIM("impairmentGroup")=$P(X,U,8)

 S FIM("onset")=$$DATE($P(X,U,9))

 S FIM("admitted")=$$DATE($P(X,U,10))

 S FIM("discharged")=$$DATE($P(X,U,11))

 S X=+$P(X,U,12) I X D

 . N Y S Y=$$INFO^VPRDTIU(X) Q:Y<1  ;draft or retracted

 . S FIM("document")=Y              ;ien^localTitle^natlTitle^VUID

 . S:$G(VPRTEXT) FIM("document","content")=$$TEXT^VPRDTIU(X)

 S X=$G(VPRM(3)) S:X FIM("admitClass")=+X

 S:$L($P(X,U,3)) FIM("interruptionCode")=$P(X,U,3)

 F I=4,6,8 I $P(X,U,I) S FIM("interruption",I)=$P(X,U,I,I+1)

 F I=5:1:9 I VPRM(I)'?1."^" D  ;has data

 . S TYPE=$S(I=5:"admission",I=6:"discharge",I=7:"interim",I=8:"follow up",1:"goals")

 . S X=VPRM(I),MOTOR=$$TOTAL(X,1,13) Q:'MOTOR  ;incomplete results

 . S COGNTV=$$TOTAL(X,14,18) Q:'COGNTV         ;incomplete results

 . S FIM("assessment",TYPE)=X

 . S FIM("assessment",TYPE,"motorScore")=MOTOR

 . S FIM("assessment",TYPE,"cognitiveScore")=COGNTV

 . S FIM("assessment",TYPE,"totalScore")=MOTOR+COGNTV

DATE(X) ; -- Return internal form of date X

 N %DT,Y

 S %DT="" D ^%DT S:Y<1 Y=X

Q Y

TOTAL(NODE,P1,P2) ; -- Return total of scores, or "" if incomplete

 N SUM,I,X

 S SUM=0 F I=P1:1:P2 S X=$P(NODE,U,I) S:X SUM=SUM+X I X<1 S SUM="" Q

 Q SUM

 ; ------------ Return data to middle tier ------------

XML(FIM) ; -- Return FIM case as XML in @VPR@(I)

 N ATT,I,J,X,Y,NAMES,TEXT

 D ADD("<fim>") S VPRTOTL=$G(VPRTOTL)+1

 S ATT="" F  S ATT=$O(FIM(ATT)) Q:ATT=""  D  D:$L(Y) ADD(Y)

 . I ATT="assessment" D  S Y="" Q

 .. D ADD("<"_ATT_"s>")

 .. S I="" F  S I=$O(FIM(ATT,I)) Q:I=""  D

 ... S Y="<"_ATT_" type='"_I,J=""

 ... F  S J=$O(FIM(ATT,I,J)) Q:J=""  S Y=Y_"' "_J_"='"_FIM(ATT,I,J)

 ... S Y=Y_"' >" D ADD(Y)

 ... S X=FIM(ATT,I) D VAL(X),ADD("</"_ATT_">")

 .. D ADD("</"_ATT_"s>")

. ;

 . I ATT?1"interruption"1N D  S Y="" Q

 .. D ADD("<"_ATT_"s>")

 .. S I=0 F  S I=$O(FIM(ATT,I)) Q:I<1  D

 ... S X=FIM(ATT,I),Y="<"_ATT_" transfer='"_$P(X,U)

 ... S:$P(X,U,2) Y=Y_"' return='"_$P(X,U,2)

 ... S Y=Y_"' >" D ADD(Y)

 .. D ADD("</"_ATT_"s>")

. ;

 . S X=$G(FIM(ATT)),Y="" Q:'$L(X)

 . I ATT="document" D  S Y="" Q

 .. S NAMES="id^localTitle^nationalTitle^vuid^Z",TEXT=$G(FIM(ATT,"content"))

 .. S Y="<"_ATT_" "_$$LOOP_$S($L(TEXT):">",1:"/>")

 .. D ADD(Y) Q:'$L(TEXT)

 .. S Y="<content xml:space='preserve'>" D ADD(Y)

 .. S I=0 F  S I=$O(@TEXT@(I)) Q:I<1  S Y=$$ESC^VPRD(@TEXT@(I)) D ADD(Y)

 .. D ADD("</content>"),ADD("</"_ATT_">")

. ;

 . I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q

 . I $L(X)>1 S NAMES="code^name^Z",Y="<"_ATT_" "_$$LOOP_"/>"

 D ADD("</fim>")

VAL(X) ; -- add FIM measurement values

 N NAMES,Y S Y=""

 S NAMES="eat^groom^bath^dressUp^dressLo^toilet^bladder^bowel^transChair^transToilet^transTub^locomWalk^locomStair^comprehend^express^interact^problem^memory^walkMode^comprehendMode^expressMode^Z"

 S Y="<values "_$$LOOP_"/>"

 D ADD(Y)

LOOP() ; -- build sub-items string from NAMES and X

 N STR,P,TAG S STR=""

 F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z"  I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "

 Q STR

ADD(X) ; Add a line @VPR@(n)=X

 S VPRI=$G(VPRI)+1

 S @VPR@(VPRI)=X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDRMIM   4653     printed  Mar 13, 2025@21:50:07                                                                                                                                                                                                    Page 2

VPRDRMIM  ;SLC/MKB -- FIM extract ;8/2/11  15:29

 +1       ;;1.0;VIRTUAL PATIENT RECORD;**5**;Sep 01, 2011;Build 21

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

 +4       ; External References          DBIA#

 +5       ; -------------------          -----

 +6       ; %DT                          10003

 +7       ; DIQ                           2056

 +8       ; RMIMRP                        4745

 +9       ;

 +10      ; ------------ Get FIM cases from VistA ------------

 +11      ;

EN(DFN,BEG,END,MAX,IFN) ; -- find patient's FIM cases

 +1        NEW VPRSITE,VPRS,VPRN,VPRY,ADM,VPRITM,VPRCNT

 +2        DO PRM^RMIMRP(.VPRSITE)

           if '$ORDER(VPRSITE(1))

               QUIT

 +3       ;

 +4       ; get one case

 +5        IF $GET(IFN)

               DO EN1(IFN,.VPRITM)

               DO XML(.VPRITM)

               GOTO ENQ

 +6       ;

 +7       ; get all patient FIM cases

 +8        SET DFN=+$GET(DFN)

           if DFN<1

               QUIT

 +9        SET BEG=$GET(BEG,1410101)

           SET END=$GET(END,4141015)

           SET MAX=$GET(MAX,9999)

           SET VPRCNT=0

 +10       SET VPRS=1

FOR

               SET VPRS=$ORDER(VPRSITE(VPRS))

               if VPRS<1

                   QUIT

               Begin DoDot:1

 +11               SET VPRN=DFN_U_VPRSITE(VPRS)

 +12               DO LC^RMIMRP(.VPRY,VPRN)

                   if VPRY(1)<1

                       QUIT

 +13               SET VPRN=1

FOR

                       SET VPRN=$ORDER(VPRY(VPRN))

                       if (VPRN<1)!(VPRCNT'<MAX)

                           QUIT

                       Begin DoDot:2

 +14                       SET ADM=$$DATE($PIECE(VPRY(VPRN),U,4))

                           if ADM<BEG

                               QUIT

                           if ADM>END

                               QUIT

 +15                       KILL VPRITM

                           DO EN1(+VPRY(VPRN),.VPRITM)

                           DO XML(.VPRITM)

 +16                       SET VPRCNT=VPRCNT+1

                       End DoDot:2

               End DoDot:1

ENQ       ;done

 +1        QUIT

 +2       ;

EN1(ID,FIM) ; -- return a case in FIM("attribute")=value

 +1        NEW VPRM,X,I,TYPE,MOTOR,COGNTV

           KILL FIM

 +2       ;invalid ien

           SET ID=+$GET(ID)

           if ID<1

               QUIT

 +3        DO GC^RMIMRP(.VPRM,ID)

 +4        SET FIM("id")=ID

           SET FIM("name")="Functional Independence Measurement"

 +5       ;local stn#^name

           SET FIM("facility")=$PIECE(VPRSITE(1),U,2)_U_$PIECE(VPRSITE(1),U)

 +6        SET X=$GET(VPRM(1))

           SET FIM("case")=$PIECE(X,U,2)

 +7        SET FIM("care")=$PIECE(X,U,7)

           SET FIM("impairmentGroup")=$PIECE(X,U,8)

 +8        SET FIM("onset")=$$DATE($PIECE(X,U,9))

 +9        SET FIM("admitted")=$$DATE($PIECE(X,U,10))

 +10       SET FIM("discharged")=$$DATE($PIECE(X,U,11))

 +11       SET X=+$PIECE(X,U,12)

           IF X

               Begin DoDot:1

 +12      ;draft or retracted

                   NEW Y

                   SET Y=$$INFO^VPRDTIU(X)

                   if Y<1

                       QUIT

 +13      ;ien^localTitle^natlTitle^VUID

                   SET FIM("document")=Y

 +14               if $GET(VPRTEXT)

                       SET FIM("document","content")=$$TEXT^VPRDTIU(X)

               End DoDot:1

 +15       SET X=$GET(VPRM(3))

           if X

               SET FIM("admitClass")=+X

 +16       if $LENGTH($PIECE(X,U,3))

               SET FIM("interruptionCode")=$PIECE(X,U,3)

 +17       FOR I=4,6,8

               IF $PIECE(X,U,I)

                   SET FIM("interruption",I)=$PIECE(X,U,I,I+1)

 +18      ;has data

           FOR I=5:1:9

               IF VPRM(I)'?1."^"

                   Begin DoDot:1

 +19                   SET TYPE=$SELECT(I=5:"admission",I=6:"discharge",I=7:"interim",I=8:"follow up",1:"goals")

 +20      ;incomplete results

                       SET X=VPRM(I)

                       SET MOTOR=$$TOTAL(X,1,13)

                       if 'MOTOR

                           QUIT

 +21      ;incomplete results

                       SET COGNTV=$$TOTAL(X,14,18)

                       if 'COGNTV

                           QUIT

 +22                   SET FIM("assessment",TYPE)=X

 +23                   SET FIM("assessment",TYPE,"motorScore")=MOTOR

 +24                   SET FIM("assessment",TYPE,"cognitiveScore")=COGNTV

 +25                   SET FIM("assessment",TYPE,"totalScore")=MOTOR+COGNTV

                   End DoDot:1

 +26       QUIT

 +27      ;

DATE(X)   ; -- Return internal form of date X

 +1        NEW %DT,Y

 +2        SET %DT=""

           DO ^%DT

           if Y<1

               SET Y=X

 +3        QUIT Y

 +4       ;

TOTAL(NODE,P1,P2) ; -- Return total of scores, or "" if incomplete

 +1        NEW SUM,I,X

 +2        SET SUM=0

           FOR I=P1:1:P2

               SET X=$PIECE(NODE,U,I)

               if X

                   SET SUM=SUM+X

               IF X<1

                   SET SUM=""

                   QUIT

 +3        QUIT SUM

 +4       ;

 +5       ; ------------ Return data to middle tier ------------

 +6       ;

XML(FIM)  ; -- Return FIM case as XML in @VPR@(I)

 +1        NEW ATT,I,J,X,Y,NAMES,TEXT

 +2        DO ADD("<fim>")

           SET VPRTOTL=$GET(VPRTOTL)+1

 +3        SET ATT=""

FOR

               SET ATT=$ORDER(FIM(ATT))

               if ATT=""

                   QUIT

               Begin DoDot:1

 +4                IF ATT="assessment"

                       Begin DoDot:2

 +5                        DO ADD("<"_ATT_"s>")

 +6                        SET I=""

FOR

                               SET I=$ORDER(FIM(ATT,I))

                               if I=""

                                   QUIT

                               Begin DoDot:3

 +7                                SET Y="<"_ATT_" type='"_I

                                   SET J=""

 +8                                FOR

                                       SET J=$ORDER(FIM(ATT,I,J))

                                       if J=""

                                           QUIT

                                       SET Y=Y_"' "_J_"='"_FIM(ATT,I,J)

 +9                                SET Y=Y_"' >"

                                   DO ADD(Y)

 +10                               SET X=FIM(ATT,I)

                                   DO VAL(X)

                                   DO ADD("</"_ATT_">")

                               End DoDot:3

 +11                       DO ADD("</"_ATT_"s>")

                       End DoDot:2

                       SET Y=""

                       QUIT

 +12      ;

 +13               IF ATT?1"interruption"1N

                       Begin DoDot:2

 +14                       DO ADD("<"_ATT_"s>")

 +15                       SET I=0

FOR

                               SET I=$ORDER(FIM(ATT,I))

                               if I<1

                                   QUIT

                               Begin DoDot:3

 +16                               SET X=FIM(ATT,I)

                                   SET Y="<"_ATT_" transfer='"_$PIECE(X,U)

 +17                               if $PIECE(X,U,2)

                                       SET Y=Y_"' return='"_$PIECE(X,U,2)

 +18                               SET Y=Y_"' >"

                                   DO ADD(Y)

                               End DoDot:3

 +19                       DO ADD("</"_ATT_"s>")

                       End DoDot:2

                       SET Y=""

                       QUIT

 +20      ;

 +21               SET X=$GET(FIM(ATT))

                   SET Y=""

                   if '$LENGTH(X)

                       QUIT

 +22               IF ATT="document"

                       Begin DoDot:2

 +23                       SET NAMES="id^localTitle^nationalTitle^vuid^Z"

                           SET TEXT=$GET(FIM(ATT,"content"))

 +24                       SET Y="<"_ATT_" "_$$LOOP_$S($LENGTH(TEXT):">",1:"/>")

 +25                       DO ADD(Y)

                           if '$LENGTH(TEXT)

                               QUIT

 +26                       SET Y="<content xml:space='preserve'>"

                           DO ADD(Y)

 +27                       SET I=0

FOR

                               SET I=$ORDER(@TEXT@(I))

                               if I<1

                                   QUIT

                               SET Y=$$ESC^VPRD(@TEXT@(I))

                               DO ADD(Y)

 +28                       DO ADD("</content>")

                           DO ADD("</"_ATT_">")

                       End DoDot:2

                       SET Y=""

                       QUIT

 +29      ;

 +30               IF X'["^"

                       SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"

                       QUIT

 +31               IF $LENGTH(X)>1

                       SET NAMES="code^name^Z"

                       SET Y="<"_ATT_" "_$$LOOP_"/>"

               End DoDot:1

               if $LENGTH(Y)

                   DO ADD(Y)

 +32       DO ADD("</fim>")

 +33       QUIT

 +34      ;

VAL(X)    ; -- add FIM measurement values

 +1        NEW NAMES,Y

           SET Y=""

 +2        SET NAMES="eat^groom^bath^dressUp^dressLo^toilet^bladder^bowel^transChair^transToilet^transTub^locomWalk^locomStair^comprehend^express^interact^problem^memory^walkMode^comprehendMode^expressMode^Z"

 +3        SET Y="<values "_$$LOOP_"/>"

 +4        DO ADD(Y)

 +5        QUIT

 +6       ;

LOOP()    ; -- build sub-items string from NAMES and X

 +1        NEW STR,P,TAG

           SET STR=""

 +2        FOR P=1:1

               SET TAG=$PIECE(NAMES,U,P)

               if TAG="Z"

                   QUIT

               IF $LENGTH($PIECE(X,U,P))

                   SET STR=STR_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "

 +3        QUIT STR

 +4       ;

ADD(X)    ; Add a line @VPR@(n)=X

 +1        SET VPRI=$GET(VPRI)+1

 +2        SET @VPR@(VPRI)=X

 +3        QUIT

VPRDRMIM.m