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

VPRP20.m

Go to the documentation of this file. 
  1. VPRP20 ;SLC/MKB -- Patch 20 postinit ;3/4/20  12:07
  1.  ;;1.0;VIRTUAL PATIENT RECORD;**20**;Sep 01, 2011;Build 9
  1.  ;;Per VHA Directive 6402, this routine should not be modified.
  1.  ;
  1. PSTINT ; -- post-init [add AVPR index to #230]
  1.  N VPRX,VPRY
  1.  S VPRX("FILE")=230
  1.  S VPRX("NAME")="AVPR"
  1.  S VPRX("TYPE")="MU"
  1.  S VPRX("USE")="A"
  1.  S VPRX("EXECUTION")="F"
  1.  S VPRX("ACTIVITY")=""
  1.  S VPRX("SHORT DESCR")="Trigger updates to VPR"
  1.  S VPRX("DESCR",1)="This is an action index that updates the Virtual Patient Record (VPR)"
  1.  S VPRX("DESCR",2)="when this record is closed. No actual cross-reference nodes are set"
  1.  S VPRX("DESCR",3)="or killed."
  1.  S VPRX("SET")="D:$L($T(EDP^VPRENC)) EDP^VPRENC(DA)"
  1.  S VPRX("KILL")="Q"
  1.  S VPRX("WHOLE KILL")="Q"
  1.  S VPRX("VAL",1)=.07              ;Closed
  1.  D CREIXN^DDMOD(.VPRX,"kW",.VPRY) ;VPRY=ien^name of index
  1.  Q
  1.  ;
  1.  ; ------------------------------------------------------------------
  1.  ; This code is called from the HealthShare CallToPopulate utility to
  1.  ; populate extension properties created by VPR*1*20 (BMS/VHIE) in:
  1.  ;    Encounters (Admissions & EDIS)
  1.  ;    Appointments, including Scheduled Admissions
  1.  ;    Documents
  1.  ;    Lab Orders (CH only)
  1.  ;    Procedures (Surgeries)
  1.  ;    Vaccinations
  1.  ;
  1. EN(START,STOP,PAT) ; -- entry point to test CTP
  1.  N VPRBDT,VPREDT,VPRPT,VPRFMT,VPRII,VPRY,VPRN
  1.  S VPRBDT=$G(START,1410102)
  1.  S VPREDT=$G(STOP,4141015) S:VPREDT?7N VPREDT=VPREDT_".24" ;end of day
  1.  I $G(PAT),+PAT=PAT S VPRPT(+PAT)=""
  1.  ;
  1.  S VPRY=$NA(^XTMP("VPRP20")) K @VPRY
  1.  S @VPRY@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Call To Populate SDA P20"
  1.  S (VPRN,VPRN("D"),VPRN("U"))=0
  1.  S VPRFMT="OPS",VPRII=0
  1.  ;
  1.  D CTP
  1.  ;
  1.  W !!," Total results returned: "_VPRN
  1.  W !,"               #updates: "_$G(VPRN("U"))
  1.  W !,"               #deletes: "_$G(VPRN("D"))
  1.  S @VPRY@("Tot")=VPRN_U_VPRN("U")_U_VPRN("D")_U_VPRII
  1.  Q
  1.  ;
  1. POST(TYPE,ID,ACT,VST,EXT) ; -- post an update to
  1.  ; @VPRY@(SEQ) = ICN ^ TYPE ^ ID ^ U/D ^ VISIT# ^ DFN ^ EXTID
  1.  ;
  1.  S TYPE=$G(TYPE),ID=$G(ID) Q:TYPE=""  Q:ID=""
  1.  S ACT=$S($G(ACT)="@":"D",1:"U")
  1.  ; add/update list
  1.  S VPRN(ACT)=+$G(VPRN(ACT))+1 I VPRFMT'="DFN" D
  1.  . S VPRN=+$G(VPRN)+1,VPRII=+$G(VPRII)+1
  1.  . S @VPRY@(VPRII)=$G(ICN)_U_$G(TYPE)_U_$G(ID)_U_$G(ACT)_U_$G(VST)_U_DFN_U_$G(EXT)
  1.  I VPRFMT="DFN",'$G(VPRPT) D
  1.  . S VPRN=+$G(VPRN)+1,VPRPT=DFN
  1.  . S VPRII=+$G(VPRII)+1,@VPRY@(VPRII)=ICN_U_DFN_U_STN
  1.  Q
  1.  ;
  1. CTP ; -- application loops [called from VPRZCTP on HealthShare]
  1.  N STN,VPRPLIST,DFN,ICN
  1.  S STN=$P($$SITE^VASITE,U,3)
  1.  S VPRPLIST=$S($D(VPRPT):"VPRPT",1:$NA(^VPR(1,2)))
  1.  S DFN=0 F  S DFN=$O(@VPRPLIST@(DFN)) Q:DFN<1  I $$VALID^VPRHS(DFN) D
  1.  . S ICN=$$GETICN^MPIF001(DFN),VPRPT="" Q:ICN<0
  1.  . D VSIT
  1.  . D SDAM ;,DGS
  1.  . D TIU,RAD,LRAP,LRMI
  1.  . D ORD
  1.  . D SRF
  1.  . D IMM
  1.  Q
  1.  ;
  1. VSIT ; -- Encounters via #9000010
  1.  ; Admissions and EDIS only
  1.  N BEG,END,IDT,ID,VAINDT,VADMVT,VAERR
  1.  S BEG=VPRBDT,END=VPREDT D IDT^VPRDVSIT
  1.  S IDT=BEG F  S IDT=$O(^AUPNVSIT("AA",DFN,IDT)) Q:IDT<1!(IDT>END)  D
  1.  . S ID=0 F  S ID=$O(^AUPNVSIT("AA",DFN,IDT,ID)) Q:ID<1  D
  1.  .. Q:$G(^XTMP("VPRPX",ID_"~"_DFN))  ;already queued
  1.  .. I $P($G(^AUPNVSIT(ID,0)),U,7)="H" S VAINDT=+$P(^(0),U) D  Q
  1.  ... K VADMVT D ADM^VADPT2 Q:$G(VADMVT)<1
  1.  ... D POST("Encounter",VADMVT_"~"_ID_";405",,,ID)
  1.  .. Q:'$O(^EDP(230,"V",ID,0))
  1.  .. D POST("Encounter",ID_";9000010",,,ID)
  1.  Q
  1.  ;
  1. SDAM ; -- Appointments via #2.98/44
  1.  ; Re-send non-cancelled appts for new properties,
  1.  ;    only send past appointments with an Outpt Encounter
  1.  ; Remove cancelled appts since SD*5.3*722
  1.  N VPRX,VPRNUM,VPRDT,X0,ACT
  1.  S VPRX("FLDS")="1;3;12",VPRX("SORT")="P"
  1.  S VPRX(1)=VPRBDT_";"_VPREDT,VPRX(4)=DFN
  1.  S VPRNUM=$$SDAPI^SDAMA301(.VPRX),VPRDT=0
  1.  F  S VPRDT=$O(^TMP($J,"SDAMA301",DFN,VPRDT)) Q:VPRDT<1  D
  1.  . S X0=$G(^TMP($J,"SDAMA301",DFN,VPRDT)),ACT=""
  1.  . ; remove cancels after SD*722
  1.  . I $P(X0,U,3)["CANCEL" Q:VPRDT<3191106  S ACT="@"
  1.  . E  Q:'$P(X0,U,12)&(VPRDT<DT)  ;past appt needs OE
  1.  . D POST("Appointment",(VPRDT_","_DFN_";2.98"),ACT)
  1.  K ^TMP($J,"SDAMA301",DFN)
  1.  Q
  1.  ;
  1. DGS ; check Sch Admissions #41.1
  1.  N VPRDA,X0,DATE,ACT
  1.  S VPRDA=0 F  S VPRDA=$O(^DGS(41.1,"B",DFN,VPRDA)) Q:VPRDA<1  D
  1.  . S X0=$G(^DGS(41.1,VPRDA,0)),DATE=$P(X0,U,2)
  1.  . Q:DATE<VPRBDT  Q:DATE>VPREDT
  1.  . S ACT=$S($P(X0,U,13):"@",1:"") ;cancelled
  1.  . I ACT="@",DATE<3200401 Q       ;never sent
  1.  . D POST("Appointment",VPRDA_";41.1",ACT)
  1.  Q
  1.  ;
  1. TIU ; -- Documents via #8925
  1.  N VPRD,VPRDA,VST
  1.  D LIST^TIUVPR(.VPRD,DFN,38,VPRBDT,VPREDT)
  1.  S VPRDA=0 F  S VPRDA=+$O(@VPRD@(VPRDA)) Q:VPRDA<1  D
  1.  . Q:$G(^XTMP("VPRPX","DOC",VPRDA))  ;queued
  1.  . S VST=$$GET1^DIQ(8925,VPRDA,.03,"I")
  1.  . D POST("Document",VPRDA_";8925",,VST,VPRDA_";TIU")
  1.  K @VPRD
  1.  Q
  1. RAD ; -- Documents via #74
  1.  N VPRXID,STS,RARPT
  1.  K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,VPRBDT,VPREDT,"99P")
  1.  S VPRXID="" F  S VPRXID=$O(^TMP($J,"RAE1",DFN,VPRXID)) Q:VPRXID=""  D
  1.  . S STS=$P($G(^TMP($J,"RAE1",DFN,VPRXID)),U,3),RARPT=+$P($G(^(VPRXID)),U,5)
  1.  . Q:STS="No Report"!(STS="Deleted")!(STS["Draft")!(STS["Released/Not")
  1.  . Q:RARPT<1  Q:$D(RARPT(RARPT))  ;already have report, for sets
  1.  . D POST("Document",RARPT_";74",,,RARPT_";RA")
  1.  . S RARPT(+RARPT)=""
  1.  K ^TMP($J,"RAE1")
  1.  Q
  1. LRAP ; -- Documents via #63.0*
  1.  N SUB,IDT,LRDFN
  1.  D RR^LR7OR1(DFN,,VPRBDT,VPREDT,"AP")
  1.  S LRDFN=+$G(^DPT(DFN,"LR")) Q:LRDFN<1
  1.  S SUB="" F  S SUB=$O(^TMP("LRRR",$J,DFN,SUB)) Q:SUB=""  D
  1.  . S IDT=0 F  S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1  I $O(^(IDT,0)) D
  1.  .. Q:$O(^LR(LRDFN,SUB,IDT,.05,0))        ;report in TIU
  1.  .. Q:'$P($G(^LR(LRDFN,SUB,IDT,0)),U,11)  ;not final results
  1.  .. D POST("Document",(IDT_","_LRDFN_"~"_SUB_";63.08"),,,IDT_";"_SUB)
  1.  K ^TMP("LRRR",$J,DFN)
  1.  Q
  1. LRMI ; -- Documents via #63.05
  1.  N IDT,LRDFN
  1.  D RR^LR7OR1(DFN,,VPRBDT,VPREDT,"MI")
  1.  S LRDFN=+$G(^DPT(DFN,"LR")) Q:LRDFN<1
  1.  S IDT=0 F  S IDT=$O(^TMP("LRRR",$J,DFN,"MI",IDT)) Q:IDT<1  I $O(^(IDT,0)) D
  1.  . Q:'$P($G(^LR(LRDFN,"MI",IDT,0)),U,3)  ;not final results
  1.  . D POST("Document",(IDT_","_LRDFN_"~MI;63.05"),,,IDT_";MI")
  1.  K ^TMP("LRRR",$J,DFN)
  1.  Q
  1.  ;
  1. ORD ; -- Lab Orders via #100
  1.  N IDX,VPRDT,VPRDA,ORIFN,X0,X3,X4,PKG,ORDAD
  1.  S IDX=$NA(^PXRMINDX(100,"PI",DFN))
  1.  F  S IDX=$Q(@IDX) Q:$QS(IDX,3)'=DFN  D
  1.  . S VPRDT=$QS(IDX,5) Q:VPRDT<VPRBDT  Q:VPRDT>VPREDT
  1.  . S VPRDA=$QS(IDX,7) Q:$P(VPRDA,";",3)>1  ;multiple OI's
  1.  . S ORIFN=+VPRDA,X0=$G(^OR(100,ORIFN,0)),X3=$G(^(3)),X4=$G(^(4))
  1.  . S PKG=$P(X0,U,14) Q:$$NMSP(PKG)'="LR"
  1.  . I $O(^OR(100,ORIFN,2,0)) D  Q  ;parent, pre-17 OpsMode
  1.  .. S:(3190401<VPRDT)&(VPRDT<3191104) ORDAD(ORIFN)=""
  1.  . Q:$P(X3,U,3)=13  ;cancelled
  1.  . Q:$P(X3,U,3)=14  ;lapsed
  1.  . Q:X4'["CH"       ;no results, or not CH
  1.  . D POST("LabOrder",ORIFN_";100",,,ORIFN)
  1.  ; delete any parent orders that got posted after Ops Mode
  1.  S ORIFN=0 F  S ORIFN=$O(ORDAD(ORIFN)) Q:ORIFN<1  D POST("LabOrder",ORIFN_";100","@",,ORIFN)
  1.  Q
  1.  ;
  1. NMSP(X) ; -- return pkg namespace (if non-PS order in group)
  1.  N Y S Y=$P($G(^DIC(9.4,+X,0)),U,2)
  1.  Q $E(Y,1,2)
  1.  ;
  1. SRF ; -- Procedures via #130
  1.  N VPRS,VPRI,I,X,ID
  1.  D LIST^SROESTV(.VPRS,DFN,VPRBDT,VPREDT,,1)
  1.  S VPRI=0 F  S VPRI=$O(@VPRS@(VPRI)) Q:VPRI<1  I $G(@VPRS@(VPRI)) D
  1.  . S I=+$O(@VPRS@(VPRI,0)) Q:I<1
  1.  . S X=$G(@VPRS@(VPRI,I)) ;TIU ien ^ $$RESOLVE^TIUSRVLO data string
  1.  . I $P(X,U,7)'="completed",$P(X,U,7)'="amended" Q
  1.  . I $P(X,U,2)["Addendum to " Q
  1.  . S VST=+$$GET1^DIQ(8925,+X,.03,"I") Q:VST<1
  1.  . S ID=+$G(@VPRS@(VPRI)) Q:'$O(^SRO(136,ID,3,0))
  1.  . D POST("Procedure",ID_";130",,VST,ID_";SR")
  1.  K @VPRS
  1.  Q
  1.  ;
  1. IMM ; -- Vaccinations via #9000010.11
  1.  N VPRSTART,VPRSTOP,FNUM,VPRIDT,ID,VST
  1.  S VPRSTART=VPRBDT,VPRSTOP=VPREDT,FNUM=9000010.11
  1.  D SORT^VPRDJ09 ;sort ^PXRMINDX into ^TMP("VPRPX",$J,IDT)
  1.  S VPRIDT=0 F  S VPRIDT=$O(^TMP("VPRPX",$J,VPRIDT)) Q:VPRIDT<1  D
  1.  . S ID=0 F  S ID=$O(^TMP("VPRPX",$J,VPRIDT,ID)) Q:ID<1  D
  1.  .. S VST=$$GET1^DIQ(9000010.11,ID,.03,"I")
  1.  .. D POST("Vaccination",ID_";9000010.11",,VST,ID)
  1.  K ^TMP("VPRPX",$J)
  1.  Q