Routine: VPRHS

VPRHS ;SLC/MKB -- HealthShare utilities ;10/25/18  15:29

 ;;1.0;VIRTUAL PATIENT RECORD;**8,10,15,16,17,19,25,27,33**;Sep 01, 2011;Build 8

 ;;Per VA Directive 6402, this routine should not be modified.

 ; External References          DBIA#

 ; -------------------          -----

 ; ^DPT                         10035

 ; %ZTLOAD                      10063

 ; DDE                           7008

 ; DICN                         10009

 ; DIK                          10013

 ; MPIF001                       2701

 ; VADPT                         3744

 ; XLFDT                        10103

 ; XUPROD                        4440

ON() ; -- return 1 or 0, if monitoring is on

 Q $P($G(^VPR(1,0)),U,2)

EN(DFN) ; -- subscribe a patient for data event monitoring

 Q:'$G(DFN)  Q:$D(^VPR(1,2,+DFN,0))

 ;S ^VPR(1,2,+DFN,0)=+DFN,^VPR(1,2,"B",+DFN,+DFN)=""

 N X,Y,DA,DIC,DINUM

 S DIC="^VPR(1,2,",DIC(0)="ULFNX",DA(1)=1,(DINUM,X)=+DFN

 D FILE^DICN

UN(DFN) ; -- unsubscribe

 Q:'$G(DFN)  Q:'$D(^VPR(1,2,+DFN,0))

 ;K ^VPR(1,2,+DFN,0),^VPR(1,2,"B",+DFN,+DFN)

 N DA,DIK

 S DA(1)=1,DA=+DFN,DIK="^VPR(1,2,"

 D ^DIK

SUBS(DFN) ; -- return 1 or 0, if patient is subscribed or not

 Q $D(^VPR(1,2,+$G(DFN),0))

QUE(DFN) ; -- create task to POST a Patient update

 Q:'$P($G(^VPR(1,0)),U,2)        ;monitoring disabled

 Q:$G(DFN)<1  Q:'$$SUBS(DFN)     ;not subscribed

 Q:$P($G(^VPR(1,2,+DFN,0)),U,2)  ;task exists

 ; create task

 N ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK

 S ZTRTN="PAT^VPRHS",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,10)

 S ZTDESC="Task single VPR SDA Patient Container update"

 S ZTIO="",ZTSAVE("DFN")="" D ^%ZTLOAD

 S:$G(ZTSK)>0 $P(^VPR(1,2,DFN,0),U,2)=ZTSK

PAT ; -- post Patient update [TASK]

 Q:'$P($G(^VPR(1,0)),U,2)                     ;monitoring disabled

 S DFN=+$G(DFN) Q:DFN<1  Q:'$D(^DPT(DFN,0))   ;not valid

 ;if in merged state, unsubscribe and use 'into' DFN

 I $$MERGED(DFN) D UN(DFN) S DFN=+$G(^DPT(DFN,-9))

 I '$$SUBS(DFN) Q  ;not subscribed

 D POST(DFN,"Patient",DFN_";2")

 S $P(^VPR(1,2,DFN,0),U,2)="",ZTREQ="@"       ;clear task

PX ; -- post an encounter update

 G TASK^VPRENC ;moved in VPR*1*19

VALID(PAT) ; -- return 1 or 0, if valid patient for HealthShare

 S PAT=+$G(PAT) I PAT<1 Q 0                 ;invalid pointer

 I '$D(^DPT(DFN,0)) Q 0                     ;invalid entry

 I $G(^DPT(PAT,.35)) Q 0                    ;death date

 I $$TESTPAT^VADPT(PAT),$$PROD^XUPROD Q 0   ;no test pats in prod

 I $$MERGED(PAT) Q 0                        ;no merged-from pats

 I '$G(^DPT(PAT,"MPI")) Q 0                 ;no ICN

Q 1

MERGED(DFN) ; -- return 1 or 0, if patient is being merged

 I $P($G(^DPT(+$G(DFN),0)),U)["MERGING INTO" Q 1

 I $G(^DPT(+$G(DFN),-9)) Q 1

Q 0

POST(DFN,TYPE,ID,ACT,VST,RES) ; -- post an update to

 ;  ^VPR(1,2,DFN,"AVPR",TYPE,ID) = seq#

 ;  ^VPR("AVPR",seq#,DFN) = ICN ^ TYPE ^ ID ^ U/D ^ VISIT#

 Q:'$P($G(^VPR(1,0)),U,2)                   ;monitoring disabled

 S DFN=+$G(DFN),TYPE=$G(TYPE),ID=$G(ID)

 Q:DFN<1  Q:TYPE=""                         ;incomplete request

 ;if in merged state, unsubscribe and use 'into' DFN

 I $$MERGED(DFN) D UN(DFN) S DFN=+$G(^DPT(DFN,-9))

 N ICN S ICN=$$GETICN^MPIF001(DFN) Q:ICN<0  ;ICN required

 ; add to ^VPR if not subscribed

 I '$$SUBS(DFN) D:$$VALID(DFN) NEW(DFN,ICN) Q

 S ACT=$S($G(ACT)="@":"D",1:"U")

P1 ;may enter here from VPRHSX1 manual update option

 N SEQ,STR S SEQ=$$NUM

 S STR=$G(ICN)_U_$G(TYPE)_U_$G(ID)_U_$G(ACT)_U_$G(VST)

 S ^VPR("AVPR",SEQ,DFN)=STR

 ; use * for subscript (whole container) if ID is null

 S ^VPR(1,2,DFN,"AVPR",TYPE,$S($G(ID)="":"*",1:ID))=SEQ ;_U_$G(ACT)_U_$G(VST)

 I $P($G(^VPR(1,0)),U,5) D XTMP(SEQ,DFN,STR) ;tracking option

 S RES=SEQ

NUM() ; -- return existing SEQ of record, or increment

 ; SAC EXEMPTION 2019-04-29 : Use of $I

 N X,Y S X=$S(ID="":"*",1:ID)

 S Y=+$G(^VPR(1,2,DFN,"AVPR",TYPE,X)) I '$D(^VPR("AVPR",Y,DFN)) S Y=0

 I Y'>0 S Y=$I(^VPR(1,1))

Q Y

NEW(DFN,ICN) ; -- post a new $$VALID patient to

 ; ^VPR(1,2,DFN,"ANEW")  = seq#

 ; ^VPR("ANEW",seq#,DFN) = ICN

 Q:$G(DFN)<1  Q:$G(^VPR(1,2,DFN,"ANEW"))

 I $G(ICN)<1 S ICN=$$GETICN^MPIF001(DFN) Q:ICN<0

 N SEQ S SEQ=$I(^VPR(1,1))

 S ^VPR("ANEW",SEQ,DFN)=ICN,^VPR(1,2,DFN,"ANEW")=SEQ

 I $P($G(^VPR(1,0)),U,5) D XTMP(SEQ,DFN,(ICN_"^ANEW")) ;tracking option

DEL(LIST,SEQ) ; -- remove ^VPR(LIST,SEQ) nodes

 N DFN,DATA,TYPE,ID

 S LIST=$G(LIST),SEQ=+$G(SEQ) Q:LIST=""  Q:SEQ<1

 S DFN=+$O(^VPR(LIST,SEQ,0)) I DFN<1 Q

 I LIST="ANEW" K ^VPR("ANEW",SEQ,DFN),^VPR(1,2,DFN,"ANEW") Q

 S DATA=$G(^VPR(LIST,SEQ,DFN)) K ^VPR("AVPR",SEQ,DFN)

 S TYPE=$P(DATA,U,2) Q:TYPE=""  ;error

 S ID=$P(DATA,U,3) S:ID="" ID="*"

 K ^VPR(1,2,DFN,"AVPR",TYPE,ID)

XTMP(SEQ,DFN,X) ; -- save data for 3 days for debugging

 N D S D=$P($H,",")

 I '$D(^XTMP("VPRHS-"_D,0)) D

 . L +^XTMP("VPRHS-"_D,0):3

 . S ^XTMP("VPRHS-"_D,0)=$$FMADD^XLFDT(DT,4)_U_DT_"^VPR update log for HealthShare"

 . L -^XTMP("VPRHS-"_D,0)

 S ^XTMP("VPRHS-"_D,SEQ,DFN)=X

GET(DFN,NAME,ID,VPRQ,MTYPE,VPRY,VPRR) ; -- return VistA data in @VPRY@(#)

 N VPRNM,VPRFN,VPRE,VPRX,VPRZ,VPRMAX,VPRSRC,VPRCTR,VPRC0

 N VPRI,VPRJ,VPRK,VPRN

 ; define default return arrays

 S VPRY=$G(VPRY,$NA(^TMP("VPR GET",$J))),VPRI=0 K @VPRY

 S VPRR=$G(VPRR,$NA(^TMP("VPR ERR",$J))),VPRJ=0 K @VPRR

 ; validate Patient

 S DFN=+$G(DFN),VPRQ("patient")=DFN

 I DFN<1!'$D(^DPT(DFN,0)) G GTQ

 ; validate/find Container

 S VPRNM=$G(NAME),VPRSRC=$G(VPRQ("source"))

 I $L(VPRNM,";")>1 S VPRSRC=$P(VPRNM,";",2),VPRNM=$P(VPRNM,";") G:VPRNM="" GTQ

 S VPRCTR=+$O(^VPRC(560.1,"C",VPRNM,0)) G:VPRCTR<1 GTQ

 S ID=$G(ID) I VPRNM="Patient",'ID&DFN S ID=DFN_";2"

 I $G(VPRQ("max")) S VPRMAX=+VPRQ("max")

GT1 ; update one record for ECR

 I ID'="",ID'="*" D  G GTQ

 . S VPRFN=+$P(ID,";",2),ID=$P(ID,";")

 . I 'VPRFN!(ID="") Q  ;D ERROR("Invalid ID: "_ID_";"_VPRFN) Q

 . S VPRK=+$O(^VPRC(560.1,"F",VPRFN,VPRCTR,0))

 . S VPRC0=$G(^VPRC(560.1,VPRCTR,1,VPRK,0)),VPRE=$P(VPRC0,U,2)

 . ; if deleting a record saved in XTMP, switch entities

 . N SEQ S SEQ=$G(VPRQ("sequence"))

 . I $G(SEQ),$P($G(^XTMP("VPR-"_+SEQ,ID)),U,4)="D",$P(VPRC0,U,3) S VPRE=$P(VPRC0,U,3)

 . I 'VPRE Q  ;D ERROR("Missing Entity: "_VPRNM_" file #"_VPRFN) Q

 . S VPRI=VPRI+1,@VPRY@(VPRI)=$$GET1^DDE(+VPRE,ID,.VPRQ,1,.VPRR)

 . S VPRJ=+$O(@VPRR@("A"),-1) ;#errors

GTA ; retrieve whole container for patient re/load

 I 'VPRSRC,$P($G(^VPRC(560.1,VPRCTR,0)),U,3) D  Q

 . S VPRE=$P($G(^VPRC(560.1,VPRCTR,0)),U,3)

 . D GET^DDE(VPRE,,.VPRQ,1,.VPRMAX,.VPRY,.VPRR)

 . S VPRJ=+$O(@VPRR@("A"),-1) S:VPRJ @VPRR@(0)=VPRJ ;#errors

 S VPRX=$NA(^TMP("VPRHS",$J)),VPRZ=$NA(^TMP("VPRHS ERR",$J))

 S VPRK=0 F  S VPRK=$O(^VPRC(560.1,VPRCTR,1,VPRK)) Q:VPRK<1  S VPRC0=$G(^(VPRK,0)) D

 . S VPRFN=+VPRC0 Q:'VPRFN  I VPRSRC,VPRFN'=VPRSRC Q

 . S VPRE=+$P(VPRC0,U,2) Q:VPRE<1  K @VPRX,@VPRZ

 . ;I 'VPRE D ERROR("Missing Entity for "_VPRNM_" file #"_VPRFN) Q

 . D GET^DDE(VPRE,,.VPRQ,1,.VPRMAX,.VPRX,.VPRZ)

 . S VPRN=0 F  S VPRN=$O(@VPRX@(VPRN)) Q:VPRN<1  S VPRI=VPRI+1,@VPRY@(VPRI)=@VPRX@(VPRN)

 . S VPRN=0 F  S VPRN=$O(@VPRZ@(VPRN)) Q:VPRN<1  S VPRJ=VPRJ+1,@VPRR@(VPRJ)=@VPRZ@(VPRN)

 K @VPRX,@VPRZ

GTQ ; return data and exit

 S @VPRY@(0)=VPRI,@VPRR@(0)=VPRJ

ERROR(MSG) ; -- return error MSG

 S VPRJ=+$G(VPRJ)+1

 S @VPRR@(VPRJ)=$G(MSG)

ENTITY(CONT,FN,ACT) ; -- find Entity

 N Y,C,I,C0 S Y=""

 S CONT=$G(CONT),FN=+$G(FN),ACT=$G(ACT)

 S C=$S(CONT:CONT,$L(CONT):+$O(^VPRC(560.1,"C",CONT,0)),1:0)

 S I=+$O(^VPRC(560.1,C,1,"B",FN,0)),C0=$G(^VPRC(560.1,C,1,I,0))

 S Y=$P(C0,U,$S(ACT="D":3,1:2))

Q Y

TEST(ENTITY,ID,DFN,SEQ) ; -- test and display a single record

 N Z,IN,ERR,DONE

 S ENTITY=$G(ENTITY),ID=$G(ID)

 S:$G(DFN) IN("patient")=DFN

 S:$G(SEQ) IN("sequence")=SEQ

 S Z=$$GET1^DDE(ENTITY,ID,.IN,1,.ERR)

 I $O(ERR(0)) W !,$G(ERR(1))

 I $L(Z) D XML^VPRHST1(Z)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRHS   7979     printed  Apr 09, 2024@21:48:15                                                                                                                                                                                                       Page 2

VPRHS     ;SLC/MKB -- HealthShare utilities ;10/25/18  15:29

 +1       ;;1.0;VIRTUAL PATIENT RECORD;**8,10,15,16,17,19,25,27,33**;Sep 01, 2011;Build 8

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ; External References          DBIA#

 +5       ; -------------------          -----

 +6       ; ^DPT                         10035

 +7       ; %ZTLOAD                      10063

 +8       ; DDE                           7008

 +9       ; DICN                         10009

 +10      ; DIK                          10013

 +11      ; MPIF001                       2701

 +12      ; VADPT                         3744

 +13      ; XLFDT                        10103

 +14      ; XUPROD                        4440

 +15      ;

 +16       QUIT

 +17      ;

ON()      ; -- return 1 or 0, if monitoring is on

 +1        QUIT $PIECE($GET(^VPR(1,0)),U,2)

 +2       ;

EN(DFN)   ; -- subscribe a patient for data event monitoring

 +1        if '$GET(DFN)

               QUIT

           if $DATA(^VPR(1,2,+DFN,0))

               QUIT

 +2       ;S ^VPR(1,2,+DFN,0)=+DFN,^VPR(1,2,"B",+DFN,+DFN)=""

 +3        NEW X,Y,DA,DIC,DINUM

 +4        SET DIC="^VPR(1,2,"

           SET DIC(0)="ULFNX"

           SET DA(1)=1

           SET (DINUM,X)=+DFN

 +5        DO FILE^DICN

 +6        QUIT

 +7       ;

UN(DFN)   ; -- unsubscribe

 +1        if '$GET(DFN)

               QUIT

           if '$DATA(^VPR(1,2,+DFN,0))

               QUIT

 +2       ;K ^VPR(1,2,+DFN,0),^VPR(1,2,"B",+DFN,+DFN)

 +3        NEW DA,DIK

 +4        SET DA(1)=1

           SET DA=+DFN

           SET DIK="^VPR(1,2,"

 +5        DO ^DIK

 +6        QUIT

 +7       ;

SUBS(DFN) ; -- return 1 or 0, if patient is subscribed or not

 +1        QUIT $DATA(^VPR(1,2,+$GET(DFN),0))

 +2       ;

QUE(DFN)  ; -- create task to POST a Patient update

 +1       ;monitoring disabled

           if '$PIECE($GET(^VPR(1,0)),U,2)

               QUIT

 +2       ;not subscribed

           if $GET(DFN)<1

               QUIT

           if '$$SUBS(DFN)

               QUIT

 +3       ;task exists

           if $PIECE($GET(^VPR(1,2,+DFN,0)),U,2)

               QUIT

 +4       ; create task

 +5        NEW ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK

 +6        SET ZTRTN="PAT^VPRHS"

           SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,10)

 +7        SET ZTDESC="Task single VPR SDA Patient Container update"

 +8        SET ZTIO=""

           SET ZTSAVE("DFN")=""

           DO ^%ZTLOAD

 +9        if $GET(ZTSK)>0

               SET $PIECE(^VPR(1,2,DFN,0),U,2)=ZTSK

 +10       QUIT

 +11      ;

PAT       ; -- post Patient update [TASK]

 +1       ;monitoring disabled

           if '$PIECE($GET(^VPR(1,0)),U,2)

               QUIT

 +2       ;not valid

           SET DFN=+$GET(DFN)

           if DFN<1

               QUIT

           if '$DATA(^DPT(DFN,0))

               QUIT

 +3       ;if in merged state, unsubscribe and use 'into' DFN

 +4        IF $$MERGED(DFN)

               DO UN(DFN)

               SET DFN=+$GET(^DPT(DFN,-9))

 +5       ;not subscribed

           IF '$$SUBS(DFN)

               QUIT

 +6        DO POST(DFN,"Patient",DFN_";2")

 +7       ;clear task

           SET $PIECE(^VPR(1,2,DFN,0),U,2)=""

           SET ZTREQ="@"

 +8        QUIT

 +9       ;

PX        ; -- post an encounter update

 +1       ;moved in VPR*1*19

           GOTO TASK^VPRENC

 +2       ;

VALID(PAT) ; -- return 1 or 0, if valid patient for HealthShare

 +1       ;invalid pointer

           SET PAT=+$GET(PAT)

           IF PAT<1

               QUIT 0

 +2       ;invalid entry

           IF '$DATA(^DPT(DFN,0))

               QUIT 0

 +3       ;death date

           IF $GET(^DPT(PAT,.35))

               QUIT 0

 +4       ;no test pats in prod

           IF $$TESTPAT^VADPT(PAT)

               IF $$PROD^XUPROD

                   QUIT 0

 +5       ;no merged-from pats

           IF $$MERGED(PAT)

               QUIT 0

 +6       ;no ICN

           IF '$GET(^DPT(PAT,"MPI"))

               QUIT 0

 +7        QUIT 1

 +8       ;

MERGED(DFN) ; -- return 1 or 0, if patient is being merged

 +1        IF $PIECE($GET(^DPT(+$GET(DFN),0)),U)["MERGING INTO"

               QUIT 1

 +2        IF $GET(^DPT(+$GET(DFN),-9))

               QUIT 1

 +3        QUIT 0

 +4       ;

POST(DFN,TYPE,ID,ACT,VST,RES) ; -- post an update to

 +1       ;  ^VPR(1,2,DFN,"AVPR",TYPE,ID) = seq#

 +2       ;  ^VPR("AVPR",seq#,DFN) = ICN ^ TYPE ^ ID ^ U/D ^ VISIT#

 +3       ;monitoring disabled

           if '$PIECE($GET(^VPR(1,0)),U,2)

               QUIT

 +4        SET DFN=+$GET(DFN)

           SET TYPE=$GET(TYPE)

           SET ID=$GET(ID)

 +5       ;incomplete request

           if DFN<1

               QUIT

           if TYPE=""

               QUIT

 +6       ;if in merged state, unsubscribe and use 'into' DFN

 +7        IF $$MERGED(DFN)

               DO UN(DFN)

               SET DFN=+$GET(^DPT(DFN,-9))

 +8       ;ICN required

           NEW ICN

           SET ICN=$$GETICN^MPIF001(DFN)

           if ICN<0

               QUIT

 +9       ; add to ^VPR if not subscribed

 +10       IF '$$SUBS(DFN)

               if $$VALID(DFN)

                   DO NEW(DFN,ICN)

               QUIT

 +11       SET ACT=$SELECT($GET(ACT)="@":"D",1:"U")

P1        ;may enter here from VPRHSX1 manual update option

 +1        NEW SEQ,STR

           SET SEQ=$$NUM

 +2        SET STR=$GET(ICN)_U_$GET(TYPE)_U_$GET(ID)_U_$GET(ACT)_U_$GET(VST)

 +3        SET ^VPR("AVPR",SEQ,DFN)=STR

 +4       ; use * for subscript (whole container) if ID is null

 +5       ;_U_$G(ACT)_U_$G(VST)

           SET ^VPR(1,2,DFN,"AVPR",TYPE,$SELECT($GET(ID)="":"*",1:ID))=SEQ

 +6       ;tracking option

           IF $PIECE($GET(^VPR(1,0)),U,5)

               DO XTMP(SEQ,DFN,STR)

 +7        SET RES=SEQ

 +8        QUIT

 +9       ;

NUM()     ; -- return existing SEQ of record, or increment

 +1       ; SAC EXEMPTION 2019-04-29 : Use of $I

 +2        NEW X,Y

           SET X=$SELECT(ID="":"*",1:ID)

 +3        SET Y=+$GET(^VPR(1,2,DFN,"AVPR",TYPE,X))

           IF '$DATA(^VPR("AVPR",Y,DFN))

               SET Y=0

 +4        IF Y'>0

VPRHS.m