VPR1P37 ;SLC/CMF -- Patch 37 postinit ;9/23/2025 12:07
;;1.0;VIRTUAL PATIENT RECORD;**37**;Sep 01, 2011;Build 10
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; "AVPR" X-REF of File #123 7610
;
ENV ;Main entry point for Environment check point.
;
S XPDABORT=""
D PROGCHK(.XPDABORT) ;checks programmer variables
I XPDABORT="" K XPDABORT
Q
;
;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
;
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
.D BMES^XPDUTL("*****")
.D MES^XPDUTL("Your programming variables are not set up properly.")
.D MES^XPDUTL("Installation aborted.")
.D MES^XPDUTL("*****")
.S XPDABORT=2
Q
;
;
; This code is called from the HealthShare CallToPopulate utility to
; resend records corrected by VPR*1*36 in:
; Observation - Vital Observations missing Unit of Measure
;
;
EN(START,STOP,TYPE,FMT,PAT,VPRY) ; -- entry point to test CTP
N VPRBDT,VPREDT,VPRTYPE,VPRPAT,VPRPT,VPRFMT,VPRII,VPRN,VPR37
S VPRBDT=$G(START,3190401)
S VPR37=$$PATCH(37)
S VPREDT=$S(+$G(STOP):STOP,VPR37'=0:VPR37,1:DT)
S VPRPAT=$NA(^VPR(1,2)) I $L($G(PAT)) D
. I +PAT=PAT S VPRPT(+PAT)="",VPRPAT="VPRPT" Q
. I ($E(PAT)="^")!($E(PAT)?1.A),$D(@PAT)>9 S VPRPAT=PAT Q
;
S VPRY=$G(VPRY,$NA(^XTMP("VPRP37"))) K @VPRY
S @VPRY@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Call To Populate SDA P37"
S (VPRN,VPRN("D"),VPRN("U"))=0
S VPRFMT=$G(FMT,"OBS,"),VPRII=0
;
S VPRTYPE=$G(TYPE,"OBS,MED,REF,INS,SOC") ;default=all tags in routine
D CTP
;
D BMES^XPDUTL(" Total results returned: "_VPRN)
D MES^XPDUTL(" #updates: "_$G(VPRN("U")))
D MES^XPDUTL(" #deletes: "_$G(VPRN("D")))
M @VPRY@("Tot")=VPRN
S @VPRY@("Tot")=VPRN_U_VPRN("U")_U_VPRN("D")_U_VPRII
D:$D(@VPRY@("Tot","OBS"))
. D MES^XPDUTL(" #OBS Domain: "_@VPRY@("Tot","OBS"))
D:$D(@VPRY@("Tot","MED"))
. D MES^XPDUTL(" #MED Domain: "_@VPRY@("Tot","MED"))
D:$D(@VPRY@("Tot","REF"))
. D MES^XPDUTL(" #REF Domain: "_@VPRY@("Tot","REF"))
D:$D(@VPRY@("Tot","INS"))
. D MES^XPDUTL(" #INS Domain: "_@VPRY@("Tot","INS"))
D:$D(@VPRY@("Tot","SOC"))
. D MES^XPDUTL(" #SOC Domain: "_@VPRY@("Tot","SOC"))
Q
;
PATCH(P) ; -- return patch P installation date
N Y,VPRI S P=+$G(P)
S Y=$$INSTALDT^XPDUTL("VPR*1.0*"_P,.VPRI)
I Y S Y=$O(VPRI(0)) ;[first]install date.time
Q Y
;
CTP ; -- main loops,called from VPRZCTP on HealthShare
; Expects VPRBDT,VPREDT,VPRTYPE,VPRPAT,VPRN
N STN,DFN,ICN,VPRT,TAG
S STN=$P($$SITE^VASITE,U,3) Q:$G(VPRTYPE)=""
I '$D(VPRPAT) S VPRPAT=$S($D(VPRPT):"VPRPT",1:$NA(^VPR(1,2)))
S DFN=0 F S DFN=$O(@VPRPAT@(DFN)) Q:DFN<1 D
. S ICN=$$ICN(DFN) Q:ICN<0
. F VPRT=1:1:$L(VPRTYPE,",") S TAG=$P(VPRTYPE,",",VPRT) I $L(TAG) D
.. S TAG=$E($$UP^XLFSTR(TAG),1,8) I $L($T(@TAG)) D @TAG
Q
;
ICN(DFN) ; -- return ICN or -1^invalid
N Y I $G(DFN)<1 S Y="-1^ERROR" G ICQ
I '$D(^DPT(DFN,0)) S Y="-1^UNDEFINED" G ICQ
I '$D(^VPR(1,2,+$G(DFN),0)) S Y="-1^UNSUBSCRIBED" G ICQ
I $$MERGED^VPRHS(DFN) S Y="-1^MERGED" G ICQ
S Y=$$GETICN^MPIF001(DFN) ;-1^error or ICN
ICQ ;exit
Q Y
;
POST(TYPE,ID,ACT,VST) ; -- post an update to
; @VPRY@(SEQ) = ICN ^ TYPE ^ ID ^ U/D ^ VISIT# ^ DFN
;
S TYPE=$G(TYPE),ID=$G(ID) Q:TYPE="" Q:ID=""
S ACT=$S($G(ACT)="@":"D",1:"U")
; add/update list
S VPRN(TAG)=+$G(VPRN(TAG))+1
S VPRN(ACT)=+$G(VPRN(ACT))+1
S VPRN=+$G(VPRN)+1,VPRII=+$G(VPRII)+1
I VPRFMT'="CNT" D ;include data node, if not just counts
. S @VPRY@(VPRII)=$G(ICN)_U_$G(TYPE)_U_$G(ID)_U_$G(ACT)_U_$G(VST)_U_DFN
S @VPRY@("DFN",DFN,VPRII)=""
S @VPRY@("DOMAIN",DFN,TYPE,VPRII)=""
Q
;
OBS ; -- Vital Observations updated Observation Value Unit update [in_i}
; Expects DFN,VPRBDT,VPREDT,VPRN
N GMRVSTR,VPRIDT,VPRTYP,ID,X0,TYP,GUID,DMAX,DRANGE
S GMRVSTR="HT;CG" ; just need a portion for this CTP; "BP;T;R;P;HT;WT;CVP;CG;PO2;PN" ;CPRS vitals data set
S DMAX=99999
S GMRVSTR(0)=$G(VPRBDT)_U_$G(VPREDT)_U_DMAX_U_1
D EN1^GMRVUT0
S VPRIDT=0 F S VPRIDT=$O(^UTILITY($J,"GMRVD",VPRIDT)) Q:VPRIDT<1 D Q:VPRN'<DMAX
. S VPRTYP="" F S VPRTYP=$O(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP)) Q:VPRTYP="" D
.. S ID=$O(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP,0)) Q:'ID
.. S X0=$G(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP,ID))
.. S TYP=$P(X0,U,3)
.. Q:TYP=""
.. D POST("Observation",ID_";120.5","U") ; Send update with new Observation Value Unit [in_i]
K ^UTILITY($J,"GMRVD")
Q
;
MED ; get inpatient medication orders without a Pharmacy Status
N ORDG,ORVP,VPRDT,ORIFN,X0,X3,X4,ORPK,PSTYPE,VPRPS
S ORDG=+$O(^ORD(100.98,"B","I RX",0)) Q:ORDG<1
S ORVP=DFN_";DPT(",VPRDT=VPRBDT
F S VPRDT=$O(^OR(100,"AW",ORVP,ORDG,VPRDT)) Q:VPRDT<1 Q:VPRDT>VPREDT D
. S ORIFN=0 F S ORIFN=$O(^OR(100,"AW",ORVP,ORDG,VPRDT,ORIFN)) Q:ORIFN<1 D
.. S X0=$G(^OR(100,ORIFN,0)),X3=$G(^(3)),X4=$G(^(4))
.. Q:$P(X3,U,3)=13 ;cancelled
.. Q:$P(X3,U,3)=14 ;lapsed
.. Q:'X4 ;not released
.. D PS1^VPRSDAP(ORIFN)
.. Q:$P(@VPRPS@(0),U,6)'="NO STATUS"
.. D POST("Medication",ORIFN_";100")
Q
;
REF ; -- Referrals via #123 where an action taken has been 'added comment'
N DA,ACT,OK,AC,X0,X
S AC=$O(^GMR(123.1,"B","ADDED COMMENT",0)) Q:AC<1
S DA=0 F S DA=$O(^GMR(123,"F",DFN,DA)) Q:DA<1 D
. S X0=$G(^GMR(123,DA,0)),X=$P(X0,U,7) S:'X X=+X0 Q:X<VPRBDT!(X>VPREDT)
. ;I $L($G(^GMR(123,DA,75))) D POST("Referral",DA_";123") Q ;DST id
. S (ACT,OK)=0
. F S ACT=$O(^GMR(123,DA,40,ACT)) Q:ACT<1 I $P(^(ACT,0),U,2)=AC S OK=1 Q
. D:OK POST("Referral",DA_";123")
Q
;
SOC ; -- Add Social History ExternalId; need all records so use entity query
; Need to add WV query too.
N DA,DSTRT,DSTOP,DMAX,DLIST,VPRNUM
S DSTRT=VPRBDT,DSTOP=VPREDT,DMAX=9999,VPRNUM=0
D HFS^VPRSDAHX ; entity query
Q:'$D(DLIST)
S VPRNUM=0 F S VPRNUM=$O(DLIST(VPRNUM)) Q:+VPRNUM<1 D
.S DA=DLIST(VPRNUM)
.D POST("SocialHistory",DA_";9000010.23")
.Q
Q
;
INS ; -- Member Enrollment via #2.312 without expiration date
N IEN,X0,EXDT
S IEN=0 F S IEN=$O(^DPT(DFN,.312,IEN)) Q:IEN<1 S X0=$G(^(IEN,0)) D
. S EXDT=$P(X0,U,4) I EXDT,EXDT<3190401 Q ;never sent to SDA
. I EXDT="" D POST("MemberEnrollment",IEN_","_DFN_";2.312")
Q
;
POSTINIT ;Main entry point for Post-init items.
; Queue off predictor to run after 10:00pm
D BMES^XPDUTL(" Queuing CTP predictor to run after 10:00pm.")
N DAY,DONE,QQ,TIME,ZTIO,ZTSK,ZTRTN,ZTDESC,ZTSAVE,ZTDTH,Y
S ZTIO="",ZTRTN="PREDICTOR^VPR1P37"
;schedule job after 10:00pm
K SCH S QQ=$$NOW^XLFDT,DAY=$P(QQ,"."),TIME=$P(QQ,".",2)
I TIME<"215900" S SCH=DAY_".2205"
I TIME>"220000" S SCH=$$NOW^XLFDT
S ZTDTH=SCH
S ZTDESC="VPR*1*37 post-install of CTP predictor."
D ^%ZTLOAD
I '$G(ZTSK) D MES^XPDUTL(" **** Queuing CTP predictor failed!!!") Q
D MES^XPDUTL(" Job number #"_ZTSK_" was queued.")
Q
;
PREDICTOR ;-- capture CTP predictor as Post Init on patch install (optional)
N VPRPRED
D EN(,,"OBS,MED,REF,INS,SOC","CNT",,.VPRPRED)
;
MSG ; add post message and send to VPR developers in Outlook
N VPRN,LINE,VPRSITE
S VPRSITE=$$SITE^VASITE
I $D(@VPRPRED@("Tot")) S VPRN=@VPRPRED@("Tot")
;I 'VPRN Q
S LINE=1
S VPRMSG(LINE,0)="There's been a VPR*1*37 PREDICTOR run at site: "_+(VPRSITE)_"." S LINE=LINE+1
S VPRMSG(LINE,0)=" ",LINE=LINE+1
S VPRMSG(LINE,0)="Total results returned: "_$P(VPRN,U),LINE=LINE+1
S VPRMSG(LINE,0)=" #updates: "_$P(VPRN,U,2),LINE=LINE+1
S VPRMSG(LINE,0)=" #deletes: "_$P(VPRN,U,3),LINE=LINE+1
D:$D(@VPRPRED@("Tot","OBS"))
. S VPRMSG(LINE,0)=" #OBS Domain: "_@VPRPRED@("Tot","OBS"),LINE=LINE+1
D:$D(@VPRPRED@("Tot","MED"))
. S VPRMSG(LINE,0)=" #MED Domain: "_@VPRPRED@("Tot","MED"),LINE=LINE+1
D:$D(@VPRPRED@("Tot","REF"))
. S VPRMSG(LINE,0)=" #REF Domain: "_@VPRPRED@("Tot","REF"),LINE=LINE+1
D:$D(@VPRPRED@("Tot","INS"))
. S VPRMSG(LINE,0)=" #INS Domain: "_@VPRPRED@("Tot","INS"),LINE=LINE+1
D:$D(@VPRPRED@("Tot","SOC"))
. S VPRMSG(LINE,0)=" #SOC Domain: "_@VPRPRED@("Tot","SOC"),LINE=LINE+1
S VPRMSG(LINE,0)=" " S LINE=LINE+1
N XMSUB,XMDUZ,XMY,XMTEXT,XMDUN
S XMSUB="VPR*1*37 >> PREDICTOR TASK COMPLETED AT SITE: #"_+(VPRSITE)
S XMDUZ=.5
K XMY
S XMY(DUZ)=""
S XMY("liana.buciuman@domain.ext")=""
S XMY("m.robert.yorty@domain.ext")=""
S XMY("chris.flegel@domain.ext")=""
S XMTEXT="VPRMSG(" D ^XMD
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPR1P37 8568 printed Sep 17, 2026@21:30:31 Page 2
VPR1P37 ;SLC/CMF -- Patch 37 postinit ;9/23/2025 12:07
+1 ;;1.0;VIRTUAL PATIENT RECORD;**37**;Sep 01, 2011;Build 10
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; "AVPR" X-REF of File #123 7610
+7 ;
ENV ;Main entry point for Environment check point.
+1 ;
+2 SET XPDABORT=""
+3 ;checks programmer variables
DO PROGCHK(.XPDABORT)
+4 IF XPDABORT=""
KILL XPDABORT
+5 QUIT
+6 ;
+7 ;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
+1 ;
+2 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+3 DO BMES^XPDUTL("*****")
+4 DO MES^XPDUTL("Your programming variables are not set up properly.")
+5 DO MES^XPDUTL("Installation aborted.")
+6 DO MES^XPDUTL("*****")
+7 SET XPDABORT=2
End DoDot:1
+8 QUIT
+9 ;
+10 ;
+11 ; This code is called from the HealthShare CallToPopulate utility to
+12 ; resend records corrected by VPR*1*36 in:
+13 ; Observation - Vital Observations missing Unit of Measure
+14 ;
+15 ;
EN(START,STOP,TYPE,FMT,PAT,VPRY) ; -- entry point to test CTP
+1 NEW VPRBDT,VPREDT,VPRTYPE,VPRPAT,VPRPT,VPRFMT,VPRII,VPRN,VPR37
+2 SET VPRBDT=$GET(START,3190401)
+3 SET VPR37=$$PATCH(37)
+4 SET VPREDT=$SELECT(+$GET(STOP):STOP,VPR37'=0:VPR37,1:DT)
+5 SET VPRPAT=$NAME(^VPR(1,2))
IF $LENGTH($GET(PAT))
Begin DoDot:1
+6 IF +PAT=PAT
SET VPRPT(+PAT)=""
SET VPRPAT="VPRPT"
QUIT
+7 IF ($EXTRACT(PAT)="^")!($EXTRACT(PAT)?1.A)
IF $DATA(@PAT)>9
SET VPRPAT=PAT
QUIT
End DoDot:1
+8 ;
+9 SET VPRY=$GET(VPRY,$NAME(^XTMP("VPRP37")))
KILL @VPRY
+10 SET @VPRY@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Call To Populate SDA P37"
+11 SET (VPRN,VPRN("D"),VPRN("U"))=0
+12 SET VPRFMT=$GET(FMT,"OBS,")
SET VPRII=0
+13 ;
+14 ;default=all tags in routine
SET VPRTYPE=$GET(TYPE,"OBS,MED,REF,INS,SOC")
+15 DO CTP
+16 ;
+17 DO BMES^XPDUTL(" Total results returned: "_VPRN)
+18 DO MES^XPDUTL(" #updates: "_$GET(VPRN("U")))
+19 DO MES^XPDUTL(" #deletes: "_$GET(VPRN("D")))
+20 MERGE @VPRY@("Tot")=VPRN
+21 SET @VPRY@("Tot")=VPRN_U_VPRN("U")_U_VPRN("D")_U_VPRII
+22 if $DATA(@VPRY@("Tot","OBS"))
Begin DoDot:1
+23 DO MES^XPDUTL(" #OBS Domain: "_@VPRY@("Tot","OBS"))
End DoDot:1
+24 if $DATA(@VPRY@("Tot","MED"))
Begin DoDot:1
+25 DO MES^XPDUTL(" #MED Domain: "_@VPRY@("Tot","MED"))
End DoDot:1
+26 if $DATA(@VPRY@("Tot","REF"))
Begin DoDot:1
+27 DO MES^XPDUTL(" #REF Domain: "_@VPRY@("Tot","REF"))
End DoDot:1
+28 if $DATA(@VPRY@("Tot","INS"))
Begin DoDot:1
+29 DO MES^XPDUTL(" #INS Domain: "_@VPRY@("Tot","INS"))
End DoDot:1
+30 if $DATA(@VPRY@("Tot","SOC"))
Begin DoDot:1
+31 DO MES^XPDUTL(" #SOC Domain: "_@VPRY@("Tot","SOC"))
End DoDot:1
+32 QUIT
+33 ;
PATCH(P) ; -- return patch P installation date
+1 NEW Y,VPRI
SET P=+$GET(P)
+2 SET Y=$$INSTALDT^XPDUTL("VPR*1.0*"_P,.VPRI)
+3 ;[first]install date.time
IF Y
SET Y=$ORDER(VPRI(0))
+4 QUIT Y
+5 ;
CTP ; -- main loops,called from VPRZCTP on HealthShare
+1 ; Expects VPRBDT,VPREDT,VPRTYPE,VPRPAT,VPRN
+2 NEW STN,DFN,ICN,VPRT,TAG
+3 SET STN=$PIECE($$SITE^VASITE,U,3)
if $GET(VPRTYPE)=""
QUIT
+4 IF '$DATA(VPRPAT)
SET VPRPAT=$SELECT($DATA(VPRPT):"VPRPT",1:$NAME(^VPR(1,2)))
+5 SET DFN=0
FOR
SET DFN=$ORDER(@VPRPAT@(DFN))
if DFN<1
QUIT
Begin DoDot:1
+6 SET ICN=$$ICN(DFN)
if ICN<0
QUIT
+7 FOR VPRT=1:1:$LENGTH(VPRTYPE,",")
SET TAG=$PIECE(VPRTYPE,",",VPRT)
IF $LENGTH(TAG)
Begin DoDot:2
+8 SET TAG=$EXTRACT($$UP^XLFSTR(TAG),1,8)
IF $LENGTH($TEXT(@TAG))
DO @TAG
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
ICN(DFN) ; -- return ICN or -1^invalid
+1 NEW Y
IF $GET(DFN)<1
SET Y="-1^ERROR"
GOTO ICQ
+2 IF '$DATA(^DPT(DFN,0))
SET Y="-1^UNDEFINED"
GOTO ICQ
+3 IF '$DATA(^VPR(1,2,+$GET(DFN),0))
SET Y="-1^UNSUBSCRIBED"
GOTO ICQ
+4 IF $$MERGED^VPRHS(DFN)
SET Y="-1^MERGED"
GOTO ICQ
+5 ;-1^error or ICN
SET Y=$$GETICN^MPIF001(DFN)
ICQ ;exit
+1 QUIT Y
+2 ;
POST(TYPE,ID,ACT,VST) ; -- post an update to
+1 ; @VPRY@(SEQ) = ICN ^ TYPE ^ ID ^ U/D ^ VISIT# ^ DFN
+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(TAG)=+$GET(VPRN(TAG))+1
+7 SET VPRN(ACT)=+$GET(VPRN(ACT))+1
+8 SET VPRN=+$GET(VPRN)+1
SET VPRII=+$GET(VPRII)+1
+9 ;include data node, if not just counts
IF VPRFMT'="CNT"
Begin DoDot:1
+10 SET @VPRY@(VPRII)=$GET(ICN)_U_$GET(TYPE)_U_$GET(ID)_U_$GET(ACT)_U_$GET(VST)_U_DFN
End DoDot:1
+11 SET @VPRY@("DFN",DFN,VPRII)=""
+12 SET @VPRY@("DOMAIN",DFN,TYPE,VPRII)=""
+13 QUIT
+14 ;
OBS ; -- Vital Observations updated Observation Value Unit update [in_i}
+1 ; Expects DFN,VPRBDT,VPREDT,VPRN
+2 NEW GMRVSTR,VPRIDT,VPRTYP,ID,X0,TYP,GUID,DMAX,DRANGE
+3 ; just need a portion for this CTP; "BP;T;R;P;HT;WT;CVP;CG;PO2;PN" ;CPRS vitals data set
SET GMRVSTR="HT;CG"
+4 SET DMAX=99999
+5 SET GMRVSTR(0)=$GET(VPRBDT)_U_$GET(VPREDT)_U_DMAX_U_1
+6 DO EN1^GMRVUT0
+7 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:1
+8 SET VPRTYP=""
FOR
SET VPRTYP=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP))
if VPRTYP=""
QUIT
Begin DoDot:2
+9 SET ID=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP,0))
if 'ID
QUIT
+10 SET X0=$GET(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP,ID))
+11 SET TYP=$PIECE(X0,U,3)
+12 if TYP=""
QUIT
+13 ; Send update with new Observation Value Unit [in_i]
DO POST("Observation",ID_";120.5","U")
End DoDot:2
End DoDot:1
if VPRN'<DMAX
QUIT
+14 KILL ^UTILITY($JOB,"GMRVD")
+15 QUIT
+16 ;
MED ; get inpatient medication orders without a Pharmacy Status
+1 NEW ORDG,ORVP,VPRDT,ORIFN,X0,X3,X4,ORPK,PSTYPE,VPRPS
+2 SET ORDG=+$ORDER(^ORD(100.98,"B","I RX",0))
if ORDG<1
QUIT
+3 SET ORVP=DFN_";DPT("
SET VPRDT=VPRBDT
+4 FOR
SET VPRDT=$ORDER(^OR(100,"AW",ORVP,ORDG,VPRDT))
if VPRDT<1
QUIT
if VPRDT>VPREDT
QUIT
Begin DoDot:1
+5 SET ORIFN=0
FOR
SET ORIFN=$ORDER(^OR(100,"AW",ORVP,ORDG,VPRDT,ORIFN))
if ORIFN<1
QUIT
Begin DoDot:2
+6 SET X0=$GET(^OR(100,ORIFN,0))
SET X3=$GET(^(3))
SET X4=$GET(^(4))
+7 ;cancelled
if $PIECE(X3,U,3)=13
QUIT
+8 ;lapsed
if $PIECE(X3,U,3)=14
QUIT
+9 ;not released
if 'X4
QUIT
+10 DO PS1^VPRSDAP(ORIFN)
+11 if $PIECE(@VPRPS@(0),U,6)'="NO STATUS"
QUIT
+12 DO POST("Medication",ORIFN_";100")
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
REF ; -- Referrals via #123 where an action taken has been 'added comment'
+1 NEW DA,ACT,OK,AC,X0,X
+2 SET AC=$ORDER(^GMR(123.1,"B","ADDED COMMENT",0))
if AC<1
QUIT
+3 SET DA=0
FOR
SET DA=$ORDER(^GMR(123,"F",DFN,DA))
if DA<1
QUIT
Begin DoDot:1
+4 SET X0=$GET(^GMR(123,DA,0))
SET X=$PIECE(X0,U,7)
if 'X
SET X=+X0
if X<VPRBDT!(X>VPREDT)
QUIT
+5 ;I $L($G(^GMR(123,DA,75))) D POST("Referral",DA_";123") Q ;DST id
+6 SET (ACT,OK)=0
+7 FOR
SET ACT=$ORDER(^GMR(123,DA,40,ACT))
if ACT<1
QUIT
IF $PIECE(^(ACT,0),U,2)=AC
SET OK=1
QUIT
+8 if OK
DO POST("Referral",DA_";123")
End DoDot:1
+9 QUIT
+10 ;
SOC ; -- Add Social History ExternalId; need all records so use entity query
+1 ; Need to add WV query too.
+2 NEW DA,DSTRT,DSTOP,DMAX,DLIST,VPRNUM
+3 SET DSTRT=VPRBDT
SET DSTOP=VPREDT
SET DMAX=9999
SET VPRNUM=0
+4 ; entity query
DO HFS^VPRSDAHX
+5 if '$DATA(DLIST)
QUIT
+6 SET VPRNUM=0
FOR
SET VPRNUM=$ORDER(DLIST(VPRNUM))
if +VPRNUM<1
QUIT
Begin DoDot:1
+7 SET DA=DLIST(VPRNUM)
+8 DO POST("SocialHistory",DA_";9000010.23")
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
INS ; -- Member Enrollment via #2.312 without expiration date
+1 NEW IEN,X0,EXDT
+2 SET IEN=0
FOR
SET IEN=$ORDER(^DPT(DFN,.312,IEN))
if IEN<1
QUIT
SET X0=$GET(^(IEN,0))
Begin DoDot:1
+3 ;never sent to SDA
SET EXDT=$PIECE(X0,U,4)
IF EXDT
IF EXDT<3190401
QUIT
+4 IF EXDT=""
DO POST("MemberEnrollment",IEN_","_DFN_";2.312")
End DoDot:1
+5 QUIT
+6 ;
POSTINIT ;Main entry point for Post-init items.
+1 ; Queue off predictor to run after 10:00pm
+2 DO BMES^XPDUTL(" Queuing CTP predictor to run after 10:00pm.")
+3 NEW DAY,DONE,QQ,TIME,ZTIO,ZTSK,ZTRTN,ZTDESC,ZTSAVE,ZTDTH,Y
+4 SET ZTIO=""
SET ZTRTN="PREDICTOR^VPR1P37"
+5 ;schedule job after 10:00pm
+6 KILL SCH
SET QQ=$$NOW^XLFDT
SET DAY=$PIECE(QQ,".")
SET TIME=$PIECE(QQ,".",2)
+7 IF TIME<"215900"
SET SCH=DAY_".2205"
+8 IF TIME>"220000"
SET SCH=$$NOW^XLFDT
+9 SET ZTDTH=SCH
+10 SET ZTDESC="VPR*1*37 post-install of CTP predictor."
+11 DO ^%ZTLOAD
+12 IF '$GET(ZTSK)
DO MES^XPDUTL(" **** Queuing CTP predictor failed!!!")
QUIT
+13 DO MES^XPDUTL(" Job number #"_ZTSK_" was queued.")
+14 QUIT
+15 ;
PREDICTOR ;-- capture CTP predictor as Post Init on patch install (optional)
+1 NEW VPRPRED
+2 DO EN(,,"OBS,MED,REF,INS,SOC","CNT",,.VPRPRED)
+3 ;
MSG ; add post message and send to VPR developers in Outlook
+1 NEW VPRN,LINE,VPRSITE
+2 SET VPRSITE=$$SITE^VASITE
+3 IF $DATA(@VPRPRED@("Tot"))
SET VPRN=@VPRPRED@("Tot")
+4 ;I 'VPRN Q
+5 SET LINE=1
+6 SET VPRMSG(LINE,0)="There's been a VPR*1*37 PREDICTOR run at site: "_+(VPRSITE)_"."
SET LINE=LINE+1
+7 SET VPRMSG(LINE,0)=" "
SET LINE=LINE+1
+8 SET VPRMSG(LINE,0)="Total results returned: "_$PIECE(VPRN,U)
SET LINE=LINE+1
+9 SET VPRMSG(LINE,0)=" #updates: "_$PIECE(VPRN,U,2)
SET LINE=LINE+1
+10 SET VPRMSG(LINE,0)=" #deletes: "_$PIECE(VPRN,U,3)
SET LINE=LINE+1
+11 if $DATA(@VPRPRED@("Tot","OBS"))
Begin DoDot:1
+12 SET VPRMSG(LINE,0)=" #OBS Domain: "_@VPRPRED@("Tot","OBS")
SET LINE=LINE+1
End DoDot:1
+13 if $DATA(@VPRPRED@("Tot","MED"))
Begin DoDot:1
+14 SET VPRMSG(LINE,0)=" #MED Domain: "_@VPRPRED@("Tot","MED")
SET LINE=LINE+1
End DoDot:1
+15 if $DATA(@VPRPRED@("Tot","REF"))
Begin DoDot:1
+16 SET VPRMSG(LINE,0)=" #REF Domain: "_@VPRPRED@("Tot","REF")
SET LINE=LINE+1
End DoDot:1
+17 if $DATA(@VPRPRED@("Tot","INS"))
Begin DoDot:1
+18 SET VPRMSG(LINE,0)=" #INS Domain: "_@VPRPRED@("Tot","INS")
SET LINE=LINE+1
End DoDot:1
+19 if $DATA(@VPRPRED@("Tot","SOC"))
Begin DoDot:1
+20 SET VPRMSG(LINE,0)=" #SOC Domain: "_@VPRPRED@("Tot","SOC")
SET LINE=LINE+1
End DoDot:1
+21 SET VPRMSG(LINE,0)=" "
SET LINE=LINE+1
+22 NEW XMSUB,XMDUZ,XMY,XMTEXT,XMDUN
+23 SET XMSUB="VPR*1*37 >> PREDICTOR TASK COMPLETED AT SITE: #"_+(VPRSITE)
+24 SET XMDUZ=.5
+25 KILL XMY
+26 SET XMY(DUZ)=""
+27 SET XMY("liana.buciuman@domain.ext")=""
+28 SET XMY("m.robert.yorty@domain.ext")=""
+29 SET XMY("chris.flegel@domain.ext")=""
+30 SET XMTEXT="VPRMSG("
DO ^XMD
+31 QUIT
+32 ;
