- 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 Feb 19, 2025@00:12:18 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
