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
Q
;
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
Q
;
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>")
Q
;
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)
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDRMIM 4653 printed Apr 09, 2024@21:46:38 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
