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