VPRSDAC ;SLC/MKB -- SDA Consult/CP utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**14,25,31**;Sep 01, 2011;Build 3
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; %DT 10003
; DIQ 2056
; GMRCAPI 6082
; GMRCGUIB 2980
; GMRCSLM1, ^TMP("GMRCR",$J) 2740
; ICDEX 5747
; ICPTCOD 1995
; LEXTRAN 4912
; MDPS1,^TMP("MDHSP",$J) 4230
; TIULQ 2693
;
QRY ; -- Consult/Request Tracking query
; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
N VPRN,VPRX,GMRCDA,GMRCGRP,GMRCSEX,TITLE
D OER^GMRCSLM1(DFN,"",DSTRT,DSTOP,"") S VPRN=0
F S VPRN=$O(^TMP("GMRCR",$J,"CS",VPRN)) Q:VPRN<1!(VPRN>DMAX) D
. S VPRX=$G(^TMP("GMRCR",$J,"CS",VPRN,0)) Q:+VPRX<1
. S DLIST(VPRN)=+VPRX
K ^TMP("GMRCR",$J,"CS")
Q
;
GMRC1(IEN) ; -- Referral ID Action
K VPRCONS,VPRCACT,VPRIFC S IEN=+$G(IEN)
D GET^GMRCAPI(.VPRCONS,IEN),ACT^GMRCAPI(.VPRCACT,IEN)
S VPRIFC=$$IFC^GMRCAPI(IEN)
Q
;
CONSNAME(IEN) ; -- return display name using fields
; Request Type (#13), To Service (#1) & Procedure/Request Type (#4)
N VPRX,Y S VPRX=$G(VPRCONS(0))
I $P(VPRX,U,8)?1.N1";ORD(101," D ;resolve old v-ptr
. S Y=$P(VPRX,U,8)
. S Y=$$GET1^DIQ(101,+Y,.01),$P(VPRX,U,8)=Y
. S $P(VPRCONS(0),U,8)=Y
S Y=$P(VPRX,U,5)
I $P(VPRX,U,17)="P",$L($P(VPRX,U,8)) S Y=$P(VPRX,U,8)_" "_Y_" Proc"
E S Y=Y_" Cons"
;I $P(VPRX,U,17)="P",$L($P(VPRX,U,8)) S Y=$P(VPRX,U,8)
;E S Y=$P(VPRX,U,5)_" Consult"
Q Y
;
PROVDX(IEN) ; -- return full Consult ProvDx string, or null/DDEOUT
N VPRICD,VPRNM,VPRDX,Y S Y=""
S VPRNM=$G(VPRCONS(30)),VPRICD=$G(VPRCONS(30.1))
; if not ICD, return free text Dx
I $P(VPRICD,U,3)'="ICD",$P(VPRICD,U,3)'="10D" D PDTXT G PDXQ
; if no code, return free text Dx
I $P(VPRICD,U)="" D PDTXT G PDXQ
; if no text, resolve code to description
I VPRNM="" D I '$L(VPRNM) D PDTXT G PDXQ
. Q:$$ICDD^ICDEX($P(VPRICD,U),.VPRDX,$P(VPRICD,U,2),$P(VPRICD,U,3))'>0
. S VPRNM=$G(VPRDX(1))
; return valid ICD code
S Y=$P(VPRICD,U)_U_VPRNM_U_$$SNAM^ICDEX($$SYS^ICDEX($P(VPRICD,U,3)))
PDXQ ;exit
Q Y
;
PDTXT ; -- return ProvDx free text
I $L(VPRNM) S Y=VPRNM_U_VPRNM Q
S DDEOUT=1
Q
;
DOCS ; - get related documents, returns DLIST(#)=8925 ien
N VPRI,VPRX
S VPRI=0 F S VPRI=$O(VPRCONS(50,VPRI)) Q:VPRI<1 S VPRX=+$G(VPRCONS(50,VPRI)) S:$$COMP^VPRSDAT(VPRX) DLIST(VPRI)=VPRX_";TIU"
I '$D(DLIST),$$DISS S DLIST(1)=$$NULL^VPRSDA ;delete value
Q
;
DISS() ; -- return 1 or 0, if result removed
N I,Y S Y=0
S I=0 F S I=$O(VPRCACT(I)) Q:I<1 D Q:Y
. I $P($G(VPRCACT(I,0)),U,2)="DISASSOCIATE RESULT" S Y=1
Q Y
;
GETACT(IEN) ; -- return DLIST(DA)='DA,IEN' of activity log entries
N I,X,X0,CNT,TIU,ACT S IEN=+$G(IEN) Q:IEN<1
D:'$O(VPRCACT(0)) ACT^GMRCAPI(.VPRCACT,IEN)
S (I,CNT)=0 F S I=$O(VPRCACT(I)) Q:I<1 D Q:CNT>499
. S X0=$G(VPRCACT(I,0)),X=$P(X0,U,2),TIU=+$P(X0,U,9)
. ; look for duplicate IR's from runaway devices
. I X="INCOMPLETE RPT" Q:$D(ACT(TIU)) S ACT(TIU)=""
. S DLIST(I)=I_","_IEN,CNT=CNT+1
Q
;
;
CPQRY ; -- Clinical Procedures query [not in use]
; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
Q N VPRN,VPRX,I,ID S VPRN=0
D MDPS1^VPRDJ03(DFN,DSTRT,DSTOP,DMAX) ;gets ^TMP("MDHSP",$J)
S I=0 F S I=$O(^TMP("MDHSP",$J,I)) Q:I<1 S VPRX=$G(^(I)) I $P(VPRX,U,3)="PR702" D Q:VPRN'<DMAX
. Q:'$P(VPRX,U,14) ;no document yet (so no enc#)
. S ^TMP("MDHSP",$J,"IEN",+$P(VPRX,U,2))=I
. S VPRN=VPRN+1,DLIST(VPRN)=+$P(VPRX,U,2)
;K ^TMP("MDHSP",$J)
Q
;
CP1(IEN) ; -- get MD nodes for procedure [ID Action]
; VPRCP = ^TMP("MDHSP",$J,I)
; VPRCN = ^GMR(123,consult,0)
; VPRTIU(field#,"I") = TIU data field
I '$D(^TMP("MDHSP",$J)) D
. S:'DFN DFN=+$$GET1^DIQ(702,IEN,.01,"I")
. N DLIST D CPQRY
S I=+$G(^TMP("MDHSP",$J,"IEN",IEN)),VPRCP=$G(^TMP("MDHSP",$J,I))
I VPRCP="" S DDEOUT=1 Q
; undo date formatting
N X,Y,%DT,VPRD
S X=$P(VPRCP,U,6) I $L(X) S %DT="STX" D ^%DT S:Y>0 $P(VPRCP,U,6)=Y
; get supporting data from Consult, TIU note
S X=+$P(VPRCP,U,13) I X D K VPRD
. D DOCLIST^GMRCGUIB(.VPRD,X) S VPRCN=$G(VPRD(0)) M VPRCN=VPRD(50)
S X=+$P(VPRCP,U,14) I X D K VPRD
. D EXTRACT^TIULQ(X,"VPRD",,".03;.05;1202;1211;1212",,,"I")
. M VPRTIU=VPRD(X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAC 4531 printed Apr 09, 2024@21:47:39 Page 2
VPRSDAC ;SLC/MKB -- SDA Consult/CP utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**14,25,31**;Sep 01, 2011;Build 3
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; %DT 10003
+7 ; DIQ 2056
+8 ; GMRCAPI 6082
+9 ; GMRCGUIB 2980
+10 ; GMRCSLM1, ^TMP("GMRCR",$J) 2740
+11 ; ICDEX 5747
+12 ; ICPTCOD 1995
+13 ; LEXTRAN 4912
+14 ; MDPS1,^TMP("MDHSP",$J) 4230
+15 ; TIULQ 2693
+16 ;
QRY ; -- Consult/Request Tracking query
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
+2 NEW VPRN,VPRX,GMRCDA,GMRCGRP,GMRCSEX,TITLE
+3 DO OER^GMRCSLM1(DFN,"",DSTRT,DSTOP,"")
SET VPRN=0
+4 FOR
SET VPRN=$ORDER(^TMP("GMRCR",$JOB,"CS",VPRN))
if VPRN<1!(VPRN>DMAX)
QUIT
Begin DoDot:1
+5 SET VPRX=$GET(^TMP("GMRCR",$JOB,"CS",VPRN,0))
if +VPRX<1
QUIT
+6 SET DLIST(VPRN)=+VPRX
End DoDot:1
+7 KILL ^TMP("GMRCR",$JOB,"CS")
+8 QUIT
+9 ;
GMRC1(IEN) ; -- Referral ID Action
+1 KILL VPRCONS,VPRCACT,VPRIFC
SET IEN=+$GET(IEN)
+2 DO GET^GMRCAPI(.VPRCONS,IEN)
DO ACT^GMRCAPI(.VPRCACT,IEN)
+3 SET VPRIFC=$$IFC^GMRCAPI(IEN)
+4 QUIT
+5 ;
CONSNAME(IEN) ; -- return display name using fields
+1 ; Request Type (#13), To Service (#1) & Procedure/Request Type (#4)
+2 NEW VPRX,Y
SET VPRX=$GET(VPRCONS(0))
+3 ;resolve old v-ptr
IF $PIECE(VPRX,U,8)?1.N1";ORD(101,"
Begin DoDot:1
+4 SET Y=$PIECE(VPRX,U,8)
+5 SET Y=$$GET1^DIQ(101,+Y,.01)
SET $PIECE(VPRX,U,8)=Y
+6 SET $PIECE(VPRCONS(0),U,8)=Y
End DoDot:1
+7 SET Y=$PIECE(VPRX,U,5)
+8 IF $PIECE(VPRX,U,17)="P"
IF $LENGTH($PIECE(VPRX,U,8))
SET Y=$PIECE(VPRX,U,8)_" "_Y_" Proc"
+9 IF '$TEST
SET Y=Y_" Cons"
+10 ;I $P(VPRX,U,17)="P",$L($P(VPRX,U,8)) S Y=$P(VPRX,U,8)
+11 ;E S Y=$P(VPRX,U,5)_" Consult"
+12 QUIT Y
+13 ;
PROVDX(IEN) ; -- return full Consult ProvDx string, or null/DDEOUT
+1 NEW VPRICD,VPRNM,VPRDX,Y
SET Y=""
+2 SET VPRNM=$GET(VPRCONS(30))
SET VPRICD=$GET(VPRCONS(30.1))
+3 ; if not ICD, return free text Dx
+4 IF $PIECE(VPRICD,U,3)'="ICD"
IF $PIECE(VPRICD,U,3)'="10D"
DO PDTXT
GOTO PDXQ
+5 ; if no code, return free text Dx
+6 IF $PIECE(VPRICD,U)=""
DO PDTXT
GOTO PDXQ
+7 ; if no text, resolve code to description
+8 IF VPRNM=""
Begin DoDot:1
+9 if $$ICDD^ICDEX($PIECE(VPRICD,U),.VPRDX,$PIECE(VPRICD,U,2),$PIECE(VPRICD,U,3))'>0
QUIT
+10 SET VPRNM=$GET(VPRDX(1))
End DoDot:1
IF '$LENGTH(VPRNM)
DO PDTXT
GOTO PDXQ
+11 ; return valid ICD code
+12 SET Y=$PIECE(VPRICD,U)_U_VPRNM_U_$$SNAM^ICDEX($$SYS^ICDEX($PIECE(VPRICD,U,3)))
PDXQ ;exit
+1 QUIT Y
+2 ;
PDTXT ; -- return ProvDx free text
+1 IF $LENGTH(VPRNM)
SET Y=VPRNM_U_VPRNM
QUIT
+2 SET DDEOUT=1
+3 QUIT
+4 ;
DOCS ; - get related documents, returns DLIST(#)=8925 ien
+1 NEW VPRI,VPRX
+2 SET VPRI=0
FOR
SET VPRI=$ORDER(VPRCONS(50,VPRI))
if VPRI<1
QUIT
SET VPRX=+$GET(VPRCONS(50,VPRI))
if $$COMP^VPRSDAT(VPRX)
SET DLIST(VPRI)=VPRX_";TIU"
+3 ;delete value
IF '$DATA(DLIST)
IF $$DISS
SET DLIST(1)=$$NULL^VPRSDA
+4 QUIT
+5 ;
DISS() ; -- return 1 or 0, if result removed
+1 NEW I,Y
SET Y=0
+2 SET I=0
FOR
SET I=$ORDER(VPRCACT(I))
if I<1
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(VPRCACT(I,0)),U,2)="DISASSOCIATE RESULT"
SET Y=1
End DoDot:1
if Y
QUIT
+4 QUIT Y
+5 ;
GETACT(IEN) ; -- return DLIST(DA)='DA,IEN' of activity log entries
+1 NEW I,X,X0,CNT,TIU,ACT
SET IEN=+$GET(IEN)
if IEN<1
QUIT
+2 if '$ORDER(VPRCACT(0))
DO ACT^GMRCAPI(.VPRCACT,IEN)
+3 SET (I,CNT)=0
FOR
SET I=$ORDER(VPRCACT(I))
if I<1
QUIT
Begin DoDot:1
+4 SET X0=$GET(VPRCACT(I,0))
SET X=$PIECE(X0,U,2)
SET TIU=+$PIECE(X0,U,9)
+5 ; look for duplicate IR's from runaway devices
+6 IF X="INCOMPLETE RPT"
if $DATA(ACT(TIU))
QUIT
SET ACT(TIU)=""
+7 SET DLIST(I)=I_","_IEN
SET CNT=CNT+1
End DoDot:1
if CNT>499
QUIT
+8 QUIT
+9 ;
+10 ;
CPQRY ; -- Clinical Procedures query [not in use]
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
+2 QUIT
NEW VPRN,VPRX,I,ID
SET VPRN=0
+3 ;gets ^TMP("MDHSP",$J)
DO MDPS1^VPRDJ03(DFN,DSTRT,DSTOP,DMAX)
+4 SET I=0
FOR
SET I=$ORDER(^TMP("MDHSP",$JOB,I))
if I<1
QUIT
SET VPRX=$GET(^(I))
IF $PIECE(VPRX,U,3)="PR702"
Begin DoDot:1
+5 ;no document yet (so no enc#)
if '$PIECE(VPRX,U,14)
QUIT
+6 SET ^TMP("MDHSP",$JOB,"IEN",+$PIECE(VPRX,U,2))=I
+7 SET VPRN=VPRN+1
SET DLIST(VPRN)=+$PIECE(VPRX,U,2)
End DoDot:1
if VPRN'<DMAX
QUIT
+8 ;K ^TMP("MDHSP",$J)
+9 QUIT
+10 ;
CP1(IEN) ; -- get MD nodes for procedure [ID Action]
+1 ; VPRCP = ^TMP("MDHSP",$J,I)
+2 ; VPRCN = ^GMR(123,consult,0)
+3 ; VPRTIU(field#,"I") = TIU data field
+4 IF '$DATA(^TMP("MDHSP",$JOB))
Begin DoDot:1
+5 if 'DFN
SET DFN=+$$GET1^DIQ(702,IEN,.01,"I")
+6 NEW DLIST
DO CPQRY
End DoDot:1
+7 SET I=+$GET(^TMP("MDHSP",$JOB,"IEN",IEN))
SET VPRCP=$GET(^TMP("MDHSP",$JOB,I))
+8 IF VPRCP=""
SET DDEOUT=1
QUIT
+9 ; undo date formatting
+10 NEW X,Y,%DT,VPRD
+11 SET X=$PIECE(VPRCP,U,6)
IF $LENGTH(X)
SET %DT="STX"
DO ^%DT
if Y>0
SET $PIECE(VPRCP,U,6)=Y
+12 ; get supporting data from Consult, TIU note
+13 SET X=+$PIECE(VPRCP,U,13)
IF X
Begin DoDot:1
+14 DO DOCLIST^GMRCGUIB(.VPRD,X)
SET VPRCN=$GET(VPRD(0))
MERGE VPRCN=VPRD(50)
End DoDot:1
KILL VPRD
+15 SET X=+$PIECE(VPRCP,U,14)
IF X
Begin DoDot:1
+16 DO EXTRACT^TIULQ(X,"VPRD",,".03;.05;1202;1211;1212",,,"I")
+17 MERGE VPRTIU=VPRD(X)
End DoDot:1
KILL VPRD
+18 QUIT
