Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPRHS

VPRHS.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; External References DBIA#
  1. ; ------------------- -----
  1. ; ^DPT 10035
  1. ; %ZTLOAD 10063
  1. ; DDE 7008
  1. ; DICN 10009
  1. ; DIK 10013
  1. ; MPIF001 2701
  1. ; VADPT 3744
  1. ; XLFDT 10103
  1. ; XUPROD 4440
  1. ;
  1. Q
  1. ;
  1. ON() ; -- return 1 or 0, if monitoring is on
  1. Q $P($G(^VPR(1,0)),U,2)
  1. ;
  1. EN(DFN) ; -- subscribe a patient for data event monitoring
  1. Q:'$G(DFN) Q:$D(^VPR(1,2,+DFN,0))
  1. ;S ^VPR(1,2,+DFN,0)=+DFN,^VPR(1,2,"B",+DFN,+DFN)=""
  1. N X,Y,DA,DIC,DINUM
  1. S DIC="^VPR(1,2,",DIC(0)="ULFNX",DA(1)=1,(DINUM,X)=+DFN
  1. D FILE^DICN
  1. Q
  1. ;
  1. UN(DFN) ; -- unsubscribe
  1. Q:'$G(DFN) Q:'$D(^VPR(1,2,+DFN,0))
  1. ;K ^VPR(1,2,+DFN,0),^VPR(1,2,"B",+DFN,+DFN)
  1. N DA,DIK
  1. S DA(1)=1,DA=+DFN,DIK="^VPR(1,2,"
  1. D ^DIK
  1. Q
  1. ;
  1. SUBS(DFN) ; -- return 1 or 0, if patient is subscribed or not
  1. Q $D(^VPR(1,2,+$G(DFN),0))
  1. ;
  1. QUE(DFN) ; -- create task to POST a Patient update
  1. Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
  1. Q:$G(DFN)<1 Q:'$$SUBS(DFN) ;not subscribed
  1. Q:$P($G(^VPR(1,2,+DFN,0)),U,2) ;task exists
  1. ; create task
  1. N ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC,ZTSK
  1. S ZTRTN="PAT^VPRHS",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,10)
  1. S ZTDESC="Task single VPR SDA Patient Container update"
  1. S ZTIO="",ZTSAVE("DFN")="" D ^%ZTLOAD
  1. S:$G(ZTSK)>0 $P(^VPR(1,2,DFN,0),U,2)=ZTSK
  1. Q
  1. ;
  1. PAT ; -- post Patient update [TASK]
  1. Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
  1. S DFN=+$G(DFN) Q:DFN<1 Q:'$D(^DPT(DFN,0)) ;not valid
  1. ;if in merged state, unsubscribe and use 'into' DFN
  1. I $$MERGED(DFN) D UN(DFN) S DFN=+$G(^DPT(DFN,-9))
  1. I '$$SUBS(DFN) Q ;not subscribed
  1. D POST(DFN,"Patient",DFN_";2")
  1. S $P(^VPR(1,2,DFN,0),U,2)="",ZTREQ="@" ;clear task
  1. Q
  1. ;
  1. PX ; -- post an encounter update
  1. G TASK^VPRENC ;moved in VPR*1*19
  1. ;
  1. VALID(PAT) ; -- return 1 or 0, if valid patient for HealthShare
  1. S PAT=+$G(PAT) I PAT<1 Q 0 ;invalid pointer
  1. I '$D(^DPT(DFN,0)) Q 0 ;invalid entry
  1. I $G(^DPT(PAT,.35)) Q 0 ;death date
  1. I $$TESTPAT^VADPT(PAT),$$PROD^XUPROD Q 0 ;no test pats in prod
  1. I $$MERGED(PAT) Q 0 ;no merged-from pats
  1. I '$G(^DPT(PAT,"MPI")) Q 0 ;no ICN
  1. Q 1
  1. ;
  1. MERGED(DFN) ; -- return 1 or 0, if patient is being merged
  1. I $P($G(^DPT(+$G(DFN),0)),U)["MERGING INTO" Q 1
  1. I $G(^DPT(+$G(DFN),-9)) Q 1
  1. Q 0
  1. ;
  1. POST(DFN,TYPE,ID,ACT,VST,RES) ; -- post an update to
  1. ; ^VPR(1,2,DFN,"AVPR",TYPE,ID) = seq#
  1. ; ^VPR("AVPR",seq#,DFN) = ICN ^ TYPE ^ ID ^ U/D ^ VISIT#
  1. Q:'$P($G(^VPR(1,0)),U,2) ;monitoring disabled
  1. S DFN=+$G(DFN),TYPE=$G(TYPE),ID=$G(ID)
  1. Q:DFN<1 Q:TYPE="" ;incomplete request
  1. ;if in merged state, unsubscribe and use 'into' DFN
  1. I $$MERGED(DFN) D UN(DFN) S DFN=+$G(^DPT(DFN,-9))
  1. N ICN S ICN=$$GETICN^MPIF001(DFN) Q:ICN<0 ;ICN required
  1. ; add to ^VPR if not subscribed
  1. I '$$SUBS(DFN) D:$$VALID(DFN) NEW(DFN,ICN) Q
  1. S ACT=$S($G(ACT)="@":"D",1:"U")
  1. P1 ;may enter here from VPRHSX1 manual update option
  1. N SEQ,STR S SEQ=$$NUM
  1. S STR=$G(ICN)_U_$G(TYPE)_U_$G(ID)_U_$G(ACT)_U_$G(VST)
  1. S ^VPR("AVPR",SEQ,DFN)=STR
  1. ; use * for subscript (whole container) if ID is null
  1. S ^VPR(1,2,DFN,"AVPR",TYPE,$S($G(ID)="":"*",1:ID))=SEQ ;_U_$G(ACT)_U_$G(VST)
  1. I $P($G(^VPR(1,0)),U,5) D XTMP(SEQ,DFN,STR) ;tracking option
  1. S RES=SEQ
  1. Q
  1. ;
  1. NUM() ; -- return existing SEQ of record, or increment
  1. ; SAC EXEMPTION 2019-04-29 : Use of $I
  1. N X,Y S X=$S(ID="":"*",1:ID)
  1. S Y=+$G(^VPR(1,2,DFN,"AVPR",TYPE,X)) I '$D(^VPR("AVPR",Y,DFN)) S Y=0
  1. I Y'>0 S Y=$I(^VPR(1,1))
  1. Q Y
  1. ;
  1. NEW(DFN,ICN) ; -- post a new $$VALID patient to
  1. ; ^VPR(1,2,DFN,"ANEW") = seq#
  1. ; ^VPR("ANEW",seq#,DFN) = ICN
  1. Q:$G(DFN)<1 Q:$G(^VPR(1,2,DFN,"ANEW"))
  1. I $G(ICN)<1 S ICN=$$GETICN^MPIF001(DFN) Q:ICN<0
  1. N SEQ S SEQ=$I(^VPR(1,1))
  1. S ^VPR("ANEW",SEQ,DFN)=ICN,^VPR(1,2,DFN,"ANEW")=SEQ
  1. I $P($G(^VPR(1,0)),U,5) D XTMP(SEQ,DFN,(ICN_"^ANEW")) ;tracking option
  1. Q
  1. ;
  1. DEL(LIST,SEQ) ; -- remove ^VPR(LIST,SEQ) nodes
  1. N DFN,DATA,TYPE,ID
  1. S LIST=$G(LIST),SEQ=+$G(SEQ) Q:LIST="" Q:SEQ<1
  1. S DFN=+$O(^VPR(LIST,SEQ,0)) I DFN<1 Q
  1. I LIST="ANEW" K ^VPR("ANEW",SEQ,DFN),^VPR(1,2,DFN,"ANEW") Q
  1. S DATA=$G(^VPR(LIST,SEQ,DFN)) K ^VPR("AVPR",SEQ,DFN)
  1. S TYPE=$P(DATA,U,2) Q:TYPE="" ;error
  1. S ID=$P(DATA,U,3) S:ID="" ID="*"
  1. K ^VPR(1,2,DFN,"AVPR",TYPE,ID)
  1. Q
  1. ;
  1. XTMP(SEQ,DFN,X) ; -- save data for 3 days for debugging
  1. N D S D=$P($H,",")
  1. I '$D(^XTMP("VPRHS-"_D,0)) D
  1. . L +^XTMP("VPRHS-"_D,0):3
  1. . S ^XTMP("VPRHS-"_D,0)=$$FMADD^XLFDT(DT,4)_U_DT_"^VPR update log for HealthShare"
  1. . L -^XTMP("VPRHS-"_D,0)
  1. S ^XTMP("VPRHS-"_D,SEQ,DFN)=X
  1. Q
  1. ;
  1. GET(DFN,NAME,ID,VPRQ,MTYPE,VPRY,VPRR) ; -- return VistA data in @VPRY@(#)
  1. N VPRNM,VPRFN,VPRE,VPRX,VPRZ,VPRMAX,VPRSRC,VPRCTR,VPRC0
  1. N VPRI,VPRJ,VPRK,VPRN
  1. ;
  1. ; define default return arrays
  1. S VPRY=$G(VPRY,$NA(^TMP("VPR GET",$J))),VPRI=0 K @VPRY
  1. S VPRR=$G(VPRR,$NA(^TMP("VPR ERR",$J))),VPRJ=0 K @VPRR
  1. ;
  1. ; validate Patient
  1. S DFN=+$G(DFN),VPRQ("patient")=DFN
  1. I DFN<1!'$D(^DPT(DFN,0)) G GTQ
  1. ;
  1. ; validate/find Container
  1. S VPRNM=$G(NAME),VPRSRC=$G(VPRQ("source"))
  1. I $L(VPRNM,";")>1 S VPRSRC=$P(VPRNM,";",2),VPRNM=$P(VPRNM,";") G:VPRNM="" GTQ
  1. S VPRCTR=+$O(^VPRC(560.1,"C",VPRNM,0)) G:VPRCTR<1 GTQ
  1. S ID=$G(ID) I VPRNM="Patient",'ID&DFN S ID=DFN_";2"
  1. I $G(VPRQ("max")) S VPRMAX=+VPRQ("max")
  1. ;
  1. GT1 ; update one record for ECR
  1. I ID'="",ID'="*" D G GTQ
  1. . S VPRFN=+$P(ID,";",2),ID=$P(ID,";")
  1. . I 'VPRFN!(ID="") Q ;D ERROR("Invalid ID: "_ID_";"_VPRFN) Q
  1. . S VPRK=+$O(^VPRC(560.1,"F",VPRFN,VPRCTR,0))
  1. . S VPRC0=$G(^VPRC(560.1,VPRCTR,1,VPRK,0)),VPRE=$P(VPRC0,U,2)
  1. . ; if deleting a record saved in XTMP, switch entities
  1. . N SEQ S SEQ=$G(VPRQ("sequence"))
  1. . I $G(SEQ),$P($G(^XTMP("VPR-"_+SEQ,ID)),U,4)="D",$P(VPRC0,U,3) S VPRE=$P(VPRC0,U,3)
  1. . I 'VPRE Q ;D ERROR("Missing Entity: "_VPRNM_" file #"_VPRFN) Q
  1. . S VPRI=VPRI+1,@VPRY@(VPRI)=$$GET1^DDE(+VPRE,ID,.VPRQ,1,.VPRR)
  1. . S VPRJ=+$O(@VPRR@("A"),-1) ;#errors
  1. ;
  1. GTA ; retrieve whole container for patient re/load
  1. I 'VPRSRC,$P($G(^VPRC(560.1,VPRCTR,0)),U,3) D Q
  1. . S VPRE=$P($G(^VPRC(560.1,VPRCTR,0)),U,3)
  1. . D GET^DDE(VPRE,,.VPRQ,1,.VPRMAX,.VPRY,.VPRR)
  1. . S VPRJ=+$O(@VPRR@("A"),-1) S:VPRJ @VPRR@(0)=VPRJ ;#errors
  1. ;
  1. S VPRX=$NA(^TMP("VPRHS",$J)),VPRZ=$NA(^TMP("VPRHS ERR",$J))
  1. S VPRK=0 F S VPRK=$O(^VPRC(560.1,VPRCTR,1,VPRK)) Q:VPRK<1 S VPRC0=$G(^(VPRK,0)) D
  1. . S VPRFN=+VPRC0 Q:'VPRFN I VPRSRC,VPRFN'=VPRSRC Q
  1. . S VPRE=+$P(VPRC0,U,2) Q:VPRE<1 K @VPRX,@VPRZ
  1. . ;I 'VPRE D ERROR("Missing Entity for "_VPRNM_" file #"_VPRFN) Q
  1. . D GET^DDE(VPRE,,.VPRQ,1,.VPRMAX,.VPRX,.VPRZ)
  1. . S VPRN=0 F S VPRN=$O(@VPRX@(VPRN)) Q:VPRN<1 S VPRI=VPRI+1,@VPRY@(VPRI)=@VPRX@(VPRN)
  1. . S VPRN=0 F S VPRN=$O(@VPRZ@(VPRN)) Q:VPRN<1 S VPRJ=VPRJ+1,@VPRR@(VPRJ)=@VPRZ@(VPRN)
  1. K @VPRX,@VPRZ
  1. ;
  1. GTQ ; return data and exit
  1. S @VPRY@(0)=VPRI,@VPRR@(0)=VPRJ
  1. Q
  1. ;
  1. ERROR(MSG) ; -- return error MSG
  1. S VPRJ=+$G(VPRJ)+1
  1. S @VPRR@(VPRJ)=$G(MSG)
  1. Q
  1. ;
  1. ENTITY(CONT,FN,ACT) ; -- find Entity
  1. N Y,C,I,C0 S Y=""
  1. S CONT=$G(CONT),FN=+$G(FN),ACT=$G(ACT)
  1. S C=$S(CONT:CONT,$L(CONT):+$O(^VPRC(560.1,"C",CONT,0)),1:0)
  1. S I=+$O(^VPRC(560.1,C,1,"B",FN,0)),C0=$G(^VPRC(560.1,C,1,I,0))
  1. S Y=$P(C0,U,$S(ACT="D":3,1:2))
  1. Q Y
  1. ;
  1. TEST(ENTITY,ID,DFN,SEQ) ; -- test and display a single record
  1. N Z,IN,ERR,DONE
  1. S ENTITY=$G(ENTITY),ID=$G(ID)
  1. S:$G(DFN) IN("patient")=DFN
  1. S:$G(SEQ) IN("sequence")=SEQ
  1. S Z=$$GET1^DDE(ENTITY,ID,.IN,1,.ERR)
  1. I $O(ERR(0)) W !,$G(ERR(1))
  1. I $L(Z) D XML^VPRHST1(Z)
  1. Q