Routine: VPRSDAC

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")

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)

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

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

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

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)

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAC   4531     printed  Feb 19, 2025@00:12:14                                                                                                                                                                                                     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

VPRSDAC.m