- 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
- ;
- Q
- ;
- 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
- Q
- ;
- 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
- Q
- ;
- 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
- Q
- ;
- 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
- Q
- ;
- 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
- Q
- ;
- 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
- Q
- ;
- 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)
- Q
- ;
- 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
- Q
- ;
- 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
- Q
- ;
- ERROR(MSG) ; -- return error MSG
- S VPRJ=+$G(VPRJ)+1
- S @VPRR@(VPRJ)=$G(MSG)
- Q
- ;
- 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)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRHS 7979 printed Jan 18, 2025@03:46:22 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