VPR1P36 ;SLC/MKB/CMF -- Patch 36 CTP ;9/13/23 10:46
;;1.0;VIRTUAL PATIENT RECORD;**36**;Sep 01, 2011;Build 23
;;Per VHA Directive 6402, this routine should not be modified.
;
;
; 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
;
;
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,VPR36
S VPRBDT=$G(START,3190401)
S VPR36=$$PATCH(36)
S VPREDT=$S(+$G(STOP):STOP,VPR36'=0:VPR36,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("VPRP36"))) K @VPRY
S @VPRY@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Call To Populate SDA P36"
S (VPRN,VPRN("D"),VPRN("U"))=0
S VPRFMT=$G(FMT,"OBS"),VPRII=0
;
S VPRTYPE=$G(TYPE,"OBS") ;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"))
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 missing Unit of Measure
; Expects DFN,VPRBDT,VPREDT,VPRN
N GMRVSTR,VPRIDT,VPRTYP,ID,X0,TYP,GUID,DMAX,DRANGE
S GMRVSTR="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 Unit of Measure
K ^UTILITY($J,"GMRVD")
Q
;
;
PO ;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^VPR1P36"
;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*36 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","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*36 PREDICTOR run at site: "_+(VPRSITE)_"." S LINE=LINE+1
S VPRMSG(LINE,0)=" ",LINE=LINE+1
S VPRMSG(LINE,0)="Total 'Observation' 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")
S VPRMSG(LINE,0)=" " S LINE=LINE+1
N XMSUB,XMDUZ,XMY,XMTEXT,XMDUN
S XMSUB="VPR*1*36 >> 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 XMTEXT="VPRMSG(" D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPR1P36 5878 printed Sep 23, 2025@20:20:44 Page 2
VPR1P36 ;SLC/MKB/CMF -- Patch 36 CTP ;9/13/23 10:46
+1 ;;1.0;VIRTUAL PATIENT RECORD;**36**;Sep 01, 2011;Build 23
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
+5 ; This code is called from the HealthShare CallToPopulate utility to
+6 ; resend records corrected by VPR*1*36 in:
+7 ; Observation - Vital Observations missing Unit of Measure
+8 ;
+9 ;
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,VPR36
+2 SET VPRBDT=$GET(START,3190401)
+3 SET VPR36=$$PATCH(36)
+4 SET VPREDT=$SELECT(+$GET(STOP):STOP,VPR36'=0:VPR36,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("VPRP36")))
KILL @VPRY
+10 SET @VPRY@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Call To Populate SDA P36"
+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")
+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 QUIT
+25 ;
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 missing Unit of Measure
+1 ; Expects DFN,VPRBDT,VPREDT,VPRN
+2 NEW GMRVSTR,VPRIDT,VPRTYP,ID,X0,TYP,GUID,DMAX,DRANGE
+3 ;CPRS vitals data set
SET GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN"
+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 Unit of Measure
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 ;
+17 ;
PO ;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^VPR1P36"
+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*36 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","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*36 PREDICTOR run at site: "_+(VPRSITE)_"."
SET LINE=LINE+1
+7 SET VPRMSG(LINE,0)=" "
SET LINE=LINE+1
+8 SET VPRMSG(LINE,0)="Total 'Observation' 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")
End DoDot:1
+13 SET VPRMSG(LINE,0)=" "
SET LINE=LINE+1
+14 NEW XMSUB,XMDUZ,XMY,XMTEXT,XMDUN
+15 SET XMSUB="VPR*1*36 >> PREDICTOR TASK COMPLETED AT SITE: #"_+(VPRSITE)
+16 SET XMDUZ=.5
+17 KILL XMY
+18 SET XMY(DUZ)=""
+19 SET XMY("liana.buciuman@domain.ext")=""
+20 SET XMY("m.robert.yorty@domain.ext")=""
+21 SET XMTEXT="VPRMSG("
DO ^XMD
+22 QUIT
