VPRSDAG ;SLC/MKB -- SDA GMR utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**27,28,31**;Sep 01, 2011;Build 3
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNPROB 5703
; ^GMPL(125.8 2974
; DIQ 2056
; GMPLEDT3 2977
; GMPLUTL2 2741
; GMRVUT0, ^UTILITY($J 1446
; GMVGETVT 5047
; GMVUTL 5046
; LEXTRAN 4912
; RMIMRP 4745
; TIULQ 2693
; XLFDT 10103
;
PROBLEMS ; -- Problem List query
; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
N ID,VPRSTS,VPRPROB,VPRN,X
S VPRSTS=$G(FILTER("status")) ;default = all problems
D LIST^GMPLUTL2(.VPRPROB,DFN,VPRSTS)
S VPRN=0 F S VPRN=$O(VPRPROB(VPRN)) Q:(VPRN<1)!(VPRN>DMAX) D
. S X=$P(VPRPROB(VPRN),U,6) I X,(X<DSTRT)!(X>DSTOP) Q ;last updated
. S DLIST(VPRN)=+VPRPROB(VPRN)
Q
;
PROB1(IEN) ; -- get info for single problem [ID Action]
I '$G(^AUPNPROB(IEN,0)) S DDEOUT=1 Q
K GMPFLD,GMPORIG
D GETFLDS^GMPLEDT3(IEN)
Q
;
SCTTEXT(CODE,IEN) ; -- get Preferred Text for SCT Code
N Y,GMPDT,LEX,LEXY S Y=""
S GMPDT=$P($G(^AUPNPROB(IEN,0)),U,8) S:'GMPDT GMPDT=DT
S LEXY=$$CODE^LEXTRAN(CODE,"SCT",GMPDT)
S:LEXY>0 Y=$G(LEX("P")) ;preferred term
Q Y
;
PROBCMT(IEN) ; -- return list of comments in
; DLIST(#) = id ^ date ^ user ^ type ^ facility ^ text
N I,J,N,X,FAC S N=0
S I=0 F S I=$O(^AUPNPROB(IEN,11,I)) Q:I<1 S FAC=$G(^(I,0)) D
. S J=0 F S J=$O(^AUPNPROB(IEN,11,I,11,J)) Q:J<1 S X=$G(^(J,0)) D
.. Q:$P(X,U,4)'="A"
.. S Y=$P(X,U,5)_U_$P(X,U,6)_U_U_FAC_U_$P(X,U,3)
.. S N=N+1,DLIST(N)=J_","_I_","_IEN_U_Y
Q
;
DELETED(IEN,FLD) ; -- return 1 or 0, if FLD value was recently deleted
N LAST,I,X,Y,WK2
S IEN=+$G(IEN),FLD=+$G(FLD),Y=0
S WK2=9999999-$$FMADD^XLFDT(DT,-14) ;Inv 2 weeks ago
S LAST=+$O(^GMPL(125.8,"AD",IEN,0)) Q:LAST>WK2 Y
S I=0 F S I=$O(^GMPL(125.8,"AD",IEN,LAST,I)) Q:I<1 D Q:Y
. S X=$G(^GMPL(125.8,I,0))
. I $P(X,U,2)=FLD,$L($P(X,U,5)),$P(X,U,6)="" S Y=1 Q
Q Y
;
;
FIMQ ; -- Functional Independence Measurements query
; Expects DSTRT, DSTOP, DMAX from DDEGET
; Returns DLIST(#)=ien, VPRSITE array
N VPRS,VPRN,VPRY,ADM,VPRCNT,RMIMTIME
D PRM^RMIMRP(.VPRSITE) Q:'$O(VPRSITE(1))
S DFN=+$G(DFN) Q:DFN<1
S 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 D Q:VPRCNT'<DMAX
.. S ADM=$$DATE($P(VPRY(VPRN),U,4)) Q:ADM<DSTRT Q:ADM>DSTOP
.. S VPRCNT=VPRCNT+1,DLIST(VPRCNT)=+VPRY(VPRN)
Q
;
DATE(X) ; -- Return internal form of date X
N %DT,Y
S %DT="" D ^%DT S:Y<1 Y=X
Q Y
;
FIM1(IEN) ; -- get info for one set of measurements [ID Action]
I '$D(VPRSITE) D PRM^RMIMRP(.VPRSITE) I '$O(VPRSITE(1)) S DDEOUT=1 Q
D GC^RMIMRP(.VPRM,IEN)
; S:'$G(DFN) ??
N NOTE S NOTE=+$P($G(VPRM(1)),U,12) K VPRTIU
D EXTRACT^TIULQ(NOTE,"VPRTIU",,"1201;1202;1302",,,"I")
M VPRM("TIU")=VPRTIU(NOTE)
Q
;
FIMS ; -- get DLIST(#)=name^value of each score
; Returns VPRFIMS = Assessment type(s) for ProblemDetail
N I,J,N,X,NAMES,SCORES,SUM,TYPE
S N=0,VPRFIMS=""
S NAMES="Eating^Grooming^Bathing^Dressing - Upper Body^Dressing - Lower Body^Toileting^Bladder Management^Bowel Management^Bed, Chair, Wheelchair^Toilet^Tub, Shower^Walk/Wheelchair^Stairs"
S NAMES=NAMES_"^Comprehension^Expression^Social Interaction^Problem Solving^Memory"
S NAMES=NAMES_"^walkMode^comprehendMode^expressMode^Z"
F I=5:1:9 I VPRM(I)'?1."^" D ;has data
. S SCORES=VPRM(I),SUM=$$TOTAL(SCORES) Q:'SUM
. S TYPE=$S(I=5:"Admission",I=6:"Discharge",I=7:"Interim",I=8:"Follow up",1:"Goals")
. S VPRFIMS=VPRFIMS_$S(VPRFIMS'="":", ",1:"")_TYPE
. ; add score set to list
. S N=N+1,DLIST(N)="Assessment Type^"_TYPE
. F J=1:1:21 S X=$P(SCORES,U,J),N=N+1,DLIST(N)=$P(NAMES,U,J)_U_X
. S N=N+1,DLIST(N)="FIM Total^"_SUM
S:$L(VPRFIMS) VPRFIMS=VPRFIMS_" Assessment"_$S(VPRFIMS[",":"s",1:"")
Q
;
TOTAL(NODE) ; -- Return total of scores, or "" if incomplete
N SUM,I,X
S SUM=0 F I=1:1:18 S X=$P(NODE,U,I) S:X SUM=SUM+X I X<1 S SUM="" Q
Q SUM
;
VIT1(IEN) ; -- get info for one Vital measurement, returns VPRGMV=^(0)
S IEN=$G(IEN) I IEN="" S DDEOUT=1 Q
D GETREC^GMVUTL(.VPRV,IEN,1)
S VPRGMV=$G(VPRV(0)) I '$G(VPRV(0)) S DDEOUT=1 Q
S VPRTYPE=$$FIELD^GMVGETVT(+$P(VPRGMV,U,3),2)
I VPRTYPE="WT" D ;get BMI for weight record
. I $G(^TMP("VPRGMV",$J,IEN)) S $P(VPRGMV,U,14)=$P(^(IEN),U,14) Q
. ; get BMI from query array if available, else call GMRVUT0
. N GMRVSTR,DFN,IDT,BMI
. S GMRVSTR=VPRTYPE,GMRVSTR(0)=+VPRGMV_U_+VPRGMV_"^1^1",DFN=+$P(VPRGMV,U,2)
. D EN1^GMRVUT0 S IDT=9999999-(+VPRGMV)
. S BMI=$P($G(^UTILITY($J,"GMRVD",IDT,VPRTYPE,IEN)),U,14)
. S:BMI'="" $P(VPRGMV,U,14)=BMI
. K ^UTILITY($J,"GMRVD")
S VPRANGE=$S($L(VPRTYPE):$$RANGE^VPRDGMV(VPRTYPE),1:"")
Q
;
VITQUAL ; -- build DLIST(#)=Qualifiers [code^name]
N I,X,QUALS
S QUALS=$G(VPRV(5))
F I=1:1 S X=$P(QUALS,U,I) Q:X="" S DLIST(I)=X
Q
;
VITCODE(IEN,SFN) ; -- return [first] code for vital type
; SubFileNumber = 120.518 for Vital Type
; 120.522 for Vital Qualifier
N VPRC,IENS,Y
D GETS^DIQ(SFN,"1,"_IEN_",","**",,"VPRC")
S IENS=$O(VPRC(SFN_1,""))
S Y=$S($L(IENS):$G(VPRC(SFN_1,IENS,.01,"I")),1:"")
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAG 5608 printed Sep 23, 2025@20:22:13 Page 2
VPRSDAG ;SLC/MKB -- SDA GMR utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**27,28,31**;Sep 01, 2011;Build 3
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNPROB 5703
+7 ; ^GMPL(125.8 2974
+8 ; DIQ 2056
+9 ; GMPLEDT3 2977
+10 ; GMPLUTL2 2741
+11 ; GMRVUT0, ^UTILITY($J 1446
+12 ; GMVGETVT 5047
+13 ; GMVUTL 5046
+14 ; LEXTRAN 4912
+15 ; RMIMRP 4745
+16 ; TIULQ 2693
+17 ; XLFDT 10103
+18 ;
PROBLEMS ; -- Problem List query
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
+2 NEW ID,VPRSTS,VPRPROB,VPRN,X
+3 ;default = all problems
SET VPRSTS=$GET(FILTER("status"))
+4 DO LIST^GMPLUTL2(.VPRPROB,DFN,VPRSTS)
+5 SET VPRN=0
FOR
SET VPRN=$ORDER(VPRPROB(VPRN))
if (VPRN<1)!(VPRN>DMAX)
QUIT
Begin DoDot:1
+6 ;last updated
SET X=$PIECE(VPRPROB(VPRN),U,6)
IF X
IF (X<DSTRT)!(X>DSTOP)
QUIT
+7 SET DLIST(VPRN)=+VPRPROB(VPRN)
End DoDot:1
+8 QUIT
+9 ;
PROB1(IEN) ; -- get info for single problem [ID Action]
+1 IF '$GET(^AUPNPROB(IEN,0))
SET DDEOUT=1
QUIT
+2 KILL GMPFLD,GMPORIG
+3 DO GETFLDS^GMPLEDT3(IEN)
+4 QUIT
+5 ;
SCTTEXT(CODE,IEN) ; -- get Preferred Text for SCT Code
+1 NEW Y,GMPDT,LEX,LEXY
SET Y=""
+2 SET GMPDT=$PIECE($GET(^AUPNPROB(IEN,0)),U,8)
if 'GMPDT
SET GMPDT=DT
+3 SET LEXY=$$CODE^LEXTRAN(CODE,"SCT",GMPDT)
+4 ;preferred term
if LEXY>0
SET Y=$GET(LEX("P"))
+5 QUIT Y
+6 ;
PROBCMT(IEN) ; -- return list of comments in
+1 ; DLIST(#) = id ^ date ^ user ^ type ^ facility ^ text
+2 NEW I,J,N,X,FAC
SET N=0
+3 SET I=0
FOR
SET I=$ORDER(^AUPNPROB(IEN,11,I))
if I<1
QUIT
SET FAC=$GET(^(I,0))
Begin DoDot:1
+4 SET J=0
FOR
SET J=$ORDER(^AUPNPROB(IEN,11,I,11,J))
if J<1
QUIT
SET X=$GET(^(J,0))
Begin DoDot:2
+5 if $PIECE(X,U,4)'="A"
QUIT
+6 SET Y=$PIECE(X,U,5)_U_$PIECE(X,U,6)_U_U_FAC_U_$PIECE(X,U,3)
+7 SET N=N+1
SET DLIST(N)=J_","_I_","_IEN_U_Y
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
DELETED(IEN,FLD) ; -- return 1 or 0, if FLD value was recently deleted
+1 NEW LAST,I,X,Y,WK2
+2 SET IEN=+$GET(IEN)
SET FLD=+$GET(FLD)
SET Y=0
+3 ;Inv 2 weeks ago
SET WK2=9999999-$$FMADD^XLFDT(DT,-14)
+4 SET LAST=+$ORDER(^GMPL(125.8,"AD",IEN,0))
if LAST>WK2
QUIT Y
+5 SET I=0
FOR
SET I=$ORDER(^GMPL(125.8,"AD",IEN,LAST,I))
if I<1
QUIT
Begin DoDot:1
+6 SET X=$GET(^GMPL(125.8,I,0))
+7 IF $PIECE(X,U,2)=FLD
IF $LENGTH($PIECE(X,U,5))
IF $PIECE(X,U,6)=""
SET Y=1
QUIT
End DoDot:1
if Y
QUIT
+8 QUIT Y
+9 ;
+10 ;
FIMQ ; -- Functional Independence Measurements query
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET
+2 ; Returns DLIST(#)=ien, VPRSITE array
+3 NEW VPRS,VPRN,VPRY,ADM,VPRCNT,RMIMTIME
+4 DO PRM^RMIMRP(.VPRSITE)
if '$ORDER(VPRSITE(1))
QUIT
+5 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+6 SET VPRCNT=0
+7 SET VPRS=1
FOR
SET VPRS=$ORDER(VPRSITE(VPRS))
if VPRS<1
QUIT
Begin DoDot:1
+8 SET VPRN=DFN_U_VPRSITE(VPRS)
+9 DO LC^RMIMRP(.VPRY,VPRN)
if VPRY(1)<1
QUIT
+10 SET VPRN=1
FOR
SET VPRN=$ORDER(VPRY(VPRN))
if VPRN<1
QUIT
Begin DoDot:2
+11 SET ADM=$$DATE($PIECE(VPRY(VPRN),U,4))
if ADM<DSTRT
QUIT
if ADM>DSTOP
QUIT
+12 SET VPRCNT=VPRCNT+1
SET DLIST(VPRCNT)=+VPRY(VPRN)
End DoDot:2
if VPRCNT'<DMAX
QUIT
End DoDot:1
+13 QUIT
+14 ;
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 ;
FIM1(IEN) ; -- get info for one set of measurements [ID Action]
+1 IF '$DATA(VPRSITE)
DO PRM^RMIMRP(.VPRSITE)
IF '$ORDER(VPRSITE(1))
SET DDEOUT=1
QUIT
+2 DO GC^RMIMRP(.VPRM,IEN)
+3 ; S:'$G(DFN) ??
+4 NEW NOTE
SET NOTE=+$PIECE($GET(VPRM(1)),U,12)
KILL VPRTIU
+5 DO EXTRACT^TIULQ(NOTE,"VPRTIU",,"1201;1202;1302",,,"I")
+6 MERGE VPRM("TIU")=VPRTIU(NOTE)
+7 QUIT
+8 ;
FIMS ; -- get DLIST(#)=name^value of each score
+1 ; Returns VPRFIMS = Assessment type(s) for ProblemDetail
+2 NEW I,J,N,X,NAMES,SCORES,SUM,TYPE
+3 SET N=0
SET VPRFIMS=""
+4 SET NAMES="Eating^Grooming^Bathing^Dressing - Upper Body^Dressing - Lower Body^Toileting^Bladder Management^Bowel Management^Bed, Chair, Wheelchair^Toilet^Tub, Shower^Walk/Wheelchair^Stairs"
+5 SET NAMES=NAMES_"^Comprehension^Expression^Social Interaction^Problem Solving^Memory"
+6 SET NAMES=NAMES_"^walkMode^comprehendMode^expressMode^Z"
+7 ;has data
FOR I=5:1:9
IF VPRM(I)'?1."^"
Begin DoDot:1
+8 SET SCORES=VPRM(I)
SET SUM=$$TOTAL(SCORES)
if 'SUM
QUIT
+9 SET TYPE=$SELECT(I=5:"Admission",I=6:"Discharge",I=7:"Interim",I=8:"Follow up",1:"Goals")
+10 SET VPRFIMS=VPRFIMS_$SELECT(VPRFIMS'="":", ",1:"")_TYPE
+11 ; add score set to list
+12 SET N=N+1
SET DLIST(N)="Assessment Type^"_TYPE
+13 FOR J=1:1:21
SET X=$PIECE(SCORES,U,J)
SET N=N+1
SET DLIST(N)=$PIECE(NAMES,U,J)_U_X
+14 SET N=N+1
SET DLIST(N)="FIM Total^"_SUM
End DoDot:1
+15 if $LENGTH(VPRFIMS)
SET VPRFIMS=VPRFIMS_" Assessment"_$SELECT(VPRFIMS[",":"s",1:"")
+16 QUIT
+17 ;
TOTAL(NODE) ; -- Return total of scores, or "" if incomplete
+1 NEW SUM,I,X
+2 SET SUM=0
FOR I=1:1:18
SET X=$PIECE(NODE,U,I)
if X
SET SUM=SUM+X
IF X<1
SET SUM=""
QUIT
+3 QUIT SUM
+4 ;
VIT1(IEN) ; -- get info for one Vital measurement, returns VPRGMV=^(0)
+1 SET IEN=$GET(IEN)
IF IEN=""
SET DDEOUT=1
QUIT
+2 DO GETREC^GMVUTL(.VPRV,IEN,1)
+3 SET VPRGMV=$GET(VPRV(0))
IF '$GET(VPRV(0))
SET DDEOUT=1
QUIT
+4 SET VPRTYPE=$$FIELD^GMVGETVT(+$PIECE(VPRGMV,U,3),2)
+5 ;get BMI for weight record
IF VPRTYPE="WT"
Begin DoDot:1
+6 IF $GET(^TMP("VPRGMV",$JOB,IEN))
SET $PIECE(VPRGMV,U,14)=$PIECE(^(IEN),U,14)
QUIT
+7 ; get BMI from query array if available, else call GMRVUT0
+8 NEW GMRVSTR,DFN,IDT,BMI
+9 SET GMRVSTR=VPRTYPE
SET GMRVSTR(0)=+VPRGMV_U_+VPRGMV_"^1^1"
SET DFN=+$PIECE(VPRGMV,U,2)
+10 DO EN1^GMRVUT0
SET IDT=9999999-(+VPRGMV)
+11 SET BMI=$PIECE($GET(^UTILITY($JOB,"GMRVD",IDT,VPRTYPE,IEN)),U,14)
+12 if BMI'=""
SET $PIECE(VPRGMV,U,14)=BMI
+13 KILL ^UTILITY($JOB,"GMRVD")
End DoDot:1
+14 SET VPRANGE=$SELECT($LENGTH(VPRTYPE):$$RANGE^VPRDGMV(VPRTYPE),1:"")
+15 QUIT
+16 ;
VITQUAL ; -- build DLIST(#)=Qualifiers [code^name]
+1 NEW I,X,QUALS
+2 SET QUALS=$GET(VPRV(5))
+3 FOR I=1:1
SET X=$PIECE(QUALS,U,I)
if X=""
QUIT
SET DLIST(I)=X
+4 QUIT
+5 ;
VITCODE(IEN,SFN) ; -- return [first] code for vital type
+1 ; SubFileNumber = 120.518 for Vital Type
+2 ; 120.522 for Vital Qualifier
+3 NEW VPRC,IENS,Y
+4 DO GETS^DIQ(SFN,"1,"_IEN_",","**",,"VPRC")
+5 SET IENS=$ORDER(VPRC(SFN_1,""))
+6 SET Y=$SELECT($LENGTH(IENS):$GET(VPRC(SFN_1,IENS,.01,"I")),1:"")
+7 QUIT Y
