VPRDCRC ;SLC/MKB,AGP -- Compute CRC32 for VistA data ;7/26/13 11:09am
;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; %ZTLOAD 10063
; MPIF001 2701
; XLFCRC 3156
; XLFDT 10103
;
CHECK(VPRCRC,FILTER) ; -- Return CRC32 checksums of VistA data
; RPC = VPR GET CHECKSUM
; where FILTER("system") = name of calling/client system
; FILTER("patientId") = DFN or DFN;ICN
; FILTER("domain") = name of desired data type (see VPRDJ0)
; FILTER("uid") = single item id to return [opt]
; FILTER("start") = start date.time of search [opt]
; FILTER("stop") = stop date.time of search [opt]
; FILTER("queued") = true or false
;
; VPRCRC returns the name of the ^TMP array containing the results
;
N DFN,NODE,QUEUED,SYS,VPRSYS
K ^TMP("VPRDCRC",$J),VPRCRC
S SYS=$G(FILTER("system")) I SYS="" Q
S DFN=$G(FILTER("patientId")) I DFN="" Q
S QUEUED=$G(FILTER("queued"))
S NODE="VPRDCRC "_SYS_"-"_"-"_DFN
S FILTER("node")=NODE
S VPRSYS=$$GET^XPAR("SYS","VPR SYSTEM NAME")
;
; - if not queued, generate checksums and exit w/values in ^TMP
I QUEUED'="true" D Q
. S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Checksum for Server "_SYS_" patient "_DFN
. D EN(.FILTER)
. M ^TMP("VPRDCRC",$J)=^XTMP(NODE,"data")
. S VPRCRC=$NA(^TMP("VPRDCRC",$J))
. K ^XTMP(NODE)
;
; - Queue job if not started, else return data if done
I +$G(^XTMP(NODE,"start"))=0 D QUEUED(.FILTER,NODE,SYS,DFN) Q
I +$G(^XTMP(NODE,"stop"))>0 D K ^XTMP(NODE)
. I $G(^XTMP(NODE,"error"))'="" S VPRCRC=^XTMP(NODE,"error") Q
. S VPRCRC=$NA(^TMP("VPRDCRC",$J))
. M ^TMP("VPRDCRC",$J)=^XTMP(NODE,"data")
Q
;
QUEUED(FILTER,NODE,SYS,DFN) ; -- start job to generate checksums
N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Checksum for Server "_SYS_" patient "_DFN
S ZTRTN="EN1^VPRDCRC",ZTDESC="Patient Checksum Extract for "_DFN
S ZTDTH=$$NOW^XLFDT(),ZTIO="",ZTSAVE("FILTER(")=""
S ^XTMP(NODE,"start")=$$NOW^XLFDT()
D ^%ZTLOAD I +$G(ZTSK)>0 S ^XTMP(NODE,"task")=+$G(ZTSK) Q ;success
S ^XTMP(NODE,"error")="Cannot start a task job"
S ^XTMP(NODE,"stop")=$$NOW^XLFDT()
S ^XTMP(NODE,"task")=ZTSK
Q
;
EN(FILTER) ; -- Return CRC values of requested data in ^XTMP(node,"data") as JSON
EN1 ; [entry point for queued job]
;
N ICN,DFN,NODE,UID,VPRP,TYPE,VPRTN,CRC
N VPRCRC,VPRSTART,VPRSTOP,VPRMAX,VPRI,VPRID,VPRTYPE ;for VPRDJ0
K ^TMP("VPRCRC",$J),^TMP("VPRCRCF",$J)
;
; parse & validate input parameters
S DFN=$G(FILTER("patientId")),VPRCRC=""
S ICN=+$P($G(DFN),";",2),DFN=+$G(DFN)
I DFN<1,ICN S DFN=+$$GETDFN^MPIF001(ICN)
Q:DFN<1!'$D(^DPT(DFN))
S NODE=$G(FILTER("node")) I NODE="" S NODE="VPRDCRC"
;
S VPRMAX=9999,VPRI=0 ;for VPRDJ0
S VPRSTART=+$G(FILTER("start"),1410102)
S VPRSTOP=+$G(FILTER("stop"),4141015)
S UID=$G(FILTER("uid")),VPRTYPE=$G(FILTER("domain"))
I $L(UID) S VPRTYPE=$P(UID,":",3),VPRID=$P(UID,":",6)
E S:VPRTYPE="" VPRTYPE=$$ALL
;
F VPRP=1:1:$L(VPRTYPE,";") S TYPE=$P(VPRTYPE,";",VPRP) I $L(TYPE) D
. S VPRTN=$$TAG^VPRDJ(TYPE)_"^VPRDJ0" Q:'$L($T(@VPRTN))
. D @VPRTN
;
I $L(UID) D G ENQ ;single item
. S CRC=$G(^TMP("VPRCRC",$J,VPRTYPE,UID))
. S ^XTMP(NODE,"data",1)=CRC,^XTMP(NODE,"stop")=$$NOW^XLFDT()
; generate checksum for each domain requested
S TYPE="" F S TYPE=$O(^TMP("VPRCRC",$J,TYPE)) Q:TYPE="" D
. S CRC="" D GET($NA(^TMP("VPRCRC",$J,TYPE)),.CRC)
. S ^TMP("VPRCRC",$J,TYPE)=CRC
I $L(VPRTYPE,";")>1 D ;get whole-chart checksum
. S CRC="" D GET($NA(^TMP("VPRCRC",$J)),.CRC)
. S ^TMP("VPRCRC",$J,"patient")=CRC
;
ENCODE ; -- return list(s) of checksums as JSON
D PREP
D ENCODE^VPRJSON($NA(^TMP("VPRCRCF",$J)),$NA(^XTMP(NODE,"data")),"ERROR")
S ^XTMP(NODE,"stop")=$$NOW^XLFDT()
;
ENQ K ^TMP("VPRCRC",$J),^TMP("VPRCRCF",$J)
Q
;
PREP ; -- reformat ^TMP("VPRCRC",$J) for JSON utility -> ^TMP("VPRCRCF",$J)
N DCNT,DOMAIN,UID,UCNT
S DOMAIN="",DCNT=0
F S DOMAIN=$O(^TMP("VPRCRC",$J,DOMAIN)) Q:DOMAIN="" D
. S ^TMP("VPRCRCF",$J,DOMAIN,"crc")=^TMP("VPRCRC",$J,DOMAIN)
. S UCNT=0,UID="" F S UID=$O(^TMP("VPRCRC",$J,DOMAIN,UID)) Q:UID="" D
.. S UCNT=UCNT+1,^TMP("VPRCRCF",$J,DOMAIN,"uids",UCNT,UID)=^TMP("VPRCRC",$J,DOMAIN,UID)
Q
;
GET(LIST,CRC) ; -- compute CRC32 value for LIST of strings
N I S CRC=$G(CRC),I=""
F S I=$O(@LIST@(I)) Q:I="" I $G(@LIST@(I))'="" S CRC=$$CRC32^XLFCRC(I_":"_@LIST@(I),CRC)
Q
;
ONE(ARRAY,COLL) ; -- process one data item [save result in ^TMP]
N LIST,UID,ATTR,CRC
S LIST=$$ATTR(COLL),UID=$G(@ARRAY@("uid")) Q:UID=""
S ATTR="" F S ATTR=$O(@ARRAY@(ATTR)) Q:ATTR="" I LIST'[(U_ATTR_U) K @ARRAY@(ATTR)
D GET(ARRAY,.CRC)
S ^TMP("VPRCRC",$J,COLL,UID)=CRC
S VPRI=VPRI+1
Q
;
GET1(ARRAY,COLL) ; -- process one data item [return result]
N LIST,ATTR,ITEM,CRC
S LIST=$$ATTR(COLL)
S ATTR="" F S ATTR=$O(@ARRAY@(ATTR)) Q:ATTR="" I LIST[(U_ATTR_U) S ITEM(ATTR)=@ARRAY@(ATTR)
D GET(ITEM,.CRC)
Q CRC
;
ALL() ; -- return string for all types of data
Q "problem;allergy;consult;vital;lab;procedure;obs;order;treatment;med;ptf;factor;immunization;exam;cpt;education;pov;skin;image;appointment;surgery;document;visit;mh"
;
ATTR(X) ; -- return list of attributes needed for collection X
N Y S Y=""
I X="vital" S Y="^observed^typeName^result^"
I X="problem" S Y="^onset^problemText^statusName^"
I X="allergy" S Y="^entered^summary^"
I X="order" S Y="^start^name^statusName^"
I X="treatment" S Y="^start^name^statusName^"
I X="med" S Y="^overallstart^name^vaStatus^"
I X="consult" S Y="^startDate^typeName^statusName^"
I X="procedure" S Y="^dateTime^name^statusName^"
I X="obs" S Y="^observed^typeName^result^"
I X="lab" S Y="^observed^typeName^"
I X="image" S Y="^dateTime^name^statusName^"
I X="surgery" S Y="^dateTime^typeName^statusName^"
I X="document" S Y="^referenceDateTime^localTitle^statusName^"
I X="mh" S Y="^administeredDateTime^name^"
I X="immunization" S Y="^administeredDateTime^name^"
I X="pov" S Y="^entered^name^"
I X="skin" S Y="^entered^name^result^"
I X="exam" S Y="^entered^name^result^"
I X="cpt" S Y="^entered^name^"
I X="education" S Y="^entered^name^result^"
I X="factor" S Y="^entered^name^"
I X="appointment" S Y="^dateTime^typeName^appointmentStatus^"
I X="visit" S Y="^dateTime^typeName^"
I X="ptf" S Y="^arrivalDateTime^icdCode^"
Q Y
;
;
TEST(FILTER) ;
N DONE,OUT
S DONE=0
F D Q:DONE=1
.D CHECK(.OUT,.FILTER)
.H 1 W !,$D(OUT)
.I $D(OUT)>0 S DONE=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDCRC 7046 printed Sep 23, 2025@20:20:46 Page 2
VPRDCRC ;SLC/MKB,AGP -- Compute CRC32 for VistA data ;7/26/13 11:09am
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; %ZTLOAD 10063
+8 ; MPIF001 2701
+9 ; XLFCRC 3156
+10 ; XLFDT 10103
+11 ;
CHECK(VPRCRC,FILTER) ; -- Return CRC32 checksums of VistA data
+1 ; RPC = VPR GET CHECKSUM
+2 ; where FILTER("system") = name of calling/client system
+3 ; FILTER("patientId") = DFN or DFN;ICN
+4 ; FILTER("domain") = name of desired data type (see VPRDJ0)
+5 ; FILTER("uid") = single item id to return [opt]
+6 ; FILTER("start") = start date.time of search [opt]
+7 ; FILTER("stop") = stop date.time of search [opt]
+8 ; FILTER("queued") = true or false
+9 ;
+10 ; VPRCRC returns the name of the ^TMP array containing the results
+11 ;
+12 NEW DFN,NODE,QUEUED,SYS,VPRSYS
+13 KILL ^TMP("VPRDCRC",$JOB),VPRCRC
+14 SET SYS=$GET(FILTER("system"))
IF SYS=""
QUIT
+15 SET DFN=$GET(FILTER("patientId"))
IF DFN=""
QUIT
+16 SET QUEUED=$GET(FILTER("queued"))
+17 SET NODE="VPRDCRC "_SYS_"-"_"-"_DFN
+18 SET FILTER("node")=NODE
+19 SET VPRSYS=$$GET^XPAR("SYS","VPR SYSTEM NAME")
+20 ;
+21 ; - if not queued, generate checksums and exit w/values in ^TMP
+22 IF QUEUED'="true"
Begin DoDot:1
+23 SET ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Checksum for Server "_SYS_" patient "_DFN
+24 DO EN(.FILTER)
+25 MERGE ^TMP("VPRDCRC",$JOB)=^XTMP(NODE,"data")
+26 SET VPRCRC=$NAME(^TMP("VPRDCRC",$JOB))
+27 KILL ^XTMP(NODE)
End DoDot:1
QUIT
+28 ;
+29 ; - Queue job if not started, else return data if done
+30 IF +$GET(^XTMP(NODE,"start"))=0
DO QUEUED(.FILTER,NODE,SYS,DFN)
QUIT
+31 IF +$GET(^XTMP(NODE,"stop"))>0
Begin DoDot:1
+32 IF $GET(^XTMP(NODE,"error"))'=""
SET VPRCRC=^XTMP(NODE,"error")
QUIT
+33 SET VPRCRC=$NAME(^TMP("VPRDCRC",$JOB))
+34 MERGE ^TMP("VPRDCRC",$JOB)=^XTMP(NODE,"data")
End DoDot:1
KILL ^XTMP(NODE)
+35 QUIT
+36 ;
QUEUED(FILTER,NODE,SYS,DFN) ; -- start job to generate checksums
+1 NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
+2 SET ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Checksum for Server "_SYS_" patient "_DFN
+3 SET ZTRTN="EN1^VPRDCRC"
SET ZTDESC="Patient Checksum Extract for "_DFN
+4 SET ZTDTH=$$NOW^XLFDT()
SET ZTIO=""
SET ZTSAVE("FILTER(")=""
+5 SET ^XTMP(NODE,"start")=$$NOW^XLFDT()
+6 ;success
DO ^%ZTLOAD
IF +$GET(ZTSK)>0
SET ^XTMP(NODE,"task")=+$GET(ZTSK)
QUIT
+7 SET ^XTMP(NODE,"error")="Cannot start a task job"
+8 SET ^XTMP(NODE,"stop")=$$NOW^XLFDT()
+9 SET ^XTMP(NODE,"task")=ZTSK
+10 QUIT
+11 ;
EN(FILTER) ; -- Return CRC values of requested data in ^XTMP(node,"data") as JSON
EN1 ; [entry point for queued job]
+1 ;
+2 NEW ICN,DFN,NODE,UID,VPRP,TYPE,VPRTN,CRC
+3 ;for VPRDJ0
NEW VPRCRC,VPRSTART,VPRSTOP,VPRMAX,VPRI,VPRID,VPRTYPE
+4 KILL ^TMP("VPRCRC",$JOB),^TMP("VPRCRCF",$JOB)
+5 ;
+6 ; parse & validate input parameters
+7 SET DFN=$GET(FILTER("patientId"))
SET VPRCRC=""
+8 SET ICN=+$PIECE($GET(DFN),";",2)
SET DFN=+$GET(DFN)
+9 IF DFN<1
IF ICN
SET DFN=+$$GETDFN^MPIF001(ICN)
+10 if DFN<1!'$DATA(^DPT(DFN))
QUIT
+11 SET NODE=$GET(FILTER("node"))
IF NODE=""
SET NODE="VPRDCRC"
+12 ;
+13 ;for VPRDJ0
SET VPRMAX=9999
SET VPRI=0
+14 SET VPRSTART=+$GET(FILTER("start"),1410102)
+15 SET VPRSTOP=+$GET(FILTER("stop"),4141015)
+16 SET UID=$GET(FILTER("uid"))
SET VPRTYPE=$GET(FILTER("domain"))
+17 IF $LENGTH(UID)
SET VPRTYPE=$PIECE(UID,":",3)
SET VPRID=$PIECE(UID,":",6)
+18 IF '$TEST
if VPRTYPE=""
SET VPRTYPE=$$ALL
+19 ;
+20 FOR VPRP=1:1:$LENGTH(VPRTYPE,";")
SET TYPE=$PIECE(VPRTYPE,";",VPRP)
IF $LENGTH(TYPE)
Begin DoDot:1
+21 SET VPRTN=$$TAG^VPRDJ(TYPE)_"^VPRDJ0"
if '$LENGTH($TEXT(@VPRTN))
QUIT
+22 DO @VPRTN
End DoDot:1
+23 ;
+24 ;single item
IF $LENGTH(UID)
Begin DoDot:1
+25 SET CRC=$GET(^TMP("VPRCRC",$JOB,VPRTYPE,UID))
+26 SET ^XTMP(NODE,"data",1)=CRC
SET ^XTMP(NODE,"stop")=$$NOW^XLFDT()
End DoDot:1
GOTO ENQ
+27 ; generate checksum for each domain requested
+28 SET TYPE=""
FOR
SET TYPE=$ORDER(^TMP("VPRCRC",$JOB,TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+29 SET CRC=""
DO GET($NAME(^TMP("VPRCRC",$JOB,TYPE)),.CRC)
+30 SET ^TMP("VPRCRC",$JOB,TYPE)=CRC
End DoDot:1
+31 ;get whole-chart checksum
IF $LENGTH(VPRTYPE,";")>1
Begin DoDot:1
+32 SET CRC=""
DO GET($NAME(^TMP("VPRCRC",$JOB)),.CRC)
+33 SET ^TMP("VPRCRC",$JOB,"patient")=CRC
End DoDot:1
+34 ;
ENCODE ; -- return list(s) of checksums as JSON
+1 DO PREP
+2 DO ENCODE^VPRJSON($NAME(^TMP("VPRCRCF",$JOB)),$NAME(^XTMP(NODE,"data")),"ERROR")
+3 SET ^XTMP(NODE,"stop")=$$NOW^XLFDT()
+4 ;
ENQ KILL ^TMP("VPRCRC",$JOB),^TMP("VPRCRCF",$JOB)
+1 QUIT
+2 ;
PREP ; -- reformat ^TMP("VPRCRC",$J) for JSON utility -> ^TMP("VPRCRCF",$J)
+1 NEW DCNT,DOMAIN,UID,UCNT
+2 SET DOMAIN=""
SET DCNT=0
+3 FOR
SET DOMAIN=$ORDER(^TMP("VPRCRC",$JOB,DOMAIN))
if DOMAIN=""
QUIT
Begin DoDot:1
+4 SET ^TMP("VPRCRCF",$JOB,DOMAIN,"crc")=^TMP("VPRCRC",$JOB,DOMAIN)
+5 SET UCNT=0
SET UID=""
FOR
SET UID=$ORDER(^TMP("VPRCRC",$JOB,DOMAIN,UID))
if UID=""
QUIT
Begin DoDot:2
+6 SET UCNT=UCNT+1
SET ^TMP("VPRCRCF",$JOB,DOMAIN,"uids",UCNT,UID)=^TMP("VPRCRC",$JOB,DOMAIN,UID)
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
GET(LIST,CRC) ; -- compute CRC32 value for LIST of strings
+1 NEW I
SET CRC=$GET(CRC)
SET I=""
+2 FOR
SET I=$ORDER(@LIST@(I))
if I=""
QUIT
IF $GET(@LIST@(I))'=""
SET CRC=$$CRC32^XLFCRC(I_":"_@LIST@(I),CRC)
+3 QUIT
+4 ;
ONE(ARRAY,COLL) ; -- process one data item [save result in ^TMP]
+1 NEW LIST,UID,ATTR,CRC
+2 SET LIST=$$ATTR(COLL)
SET UID=$GET(@ARRAY@("uid"))
if UID=""
QUIT
+3 SET ATTR=""
FOR
SET ATTR=$ORDER(@ARRAY@(ATTR))
if ATTR=""
QUIT
IF LIST'[(U_ATTR_U)
KILL @ARRAY@(ATTR)
+4 DO GET(ARRAY,.CRC)
+5 SET ^TMP("VPRCRC",$JOB,COLL,UID)=CRC
+6 SET VPRI=VPRI+1
+7 QUIT
+8 ;
GET1(ARRAY,COLL) ; -- process one data item [return result]
+1 NEW LIST,ATTR,ITEM,CRC
+2 SET LIST=$$ATTR(COLL)
+3 SET ATTR=""
FOR
SET ATTR=$ORDER(@ARRAY@(ATTR))
if ATTR=""
QUIT
IF LIST[(U_ATTR_U)
SET ITEM(ATTR)=@ARRAY@(ATTR)
+4 DO GET(ITEM,.CRC)
+5 QUIT CRC
+6 ;
ALL() ; -- return string for all types of data
+1 QUIT "problem;allergy;consult;vital;lab;procedure;obs;order;treatment;med;ptf;factor;immunization;exam;cpt;education;pov;skin;image;appointment;surgery;document;visit;mh"
+2 ;
ATTR(X) ; -- return list of attributes needed for collection X
+1 NEW Y
SET Y=""
+2 IF X="vital"
SET Y="^observed^typeName^result^"
+3 IF X="problem"
SET Y="^onset^problemText^statusName^"
+4 IF X="allergy"
SET Y="^entered^summary^"
+5 IF X="order"
SET Y="^start^name^statusName^"
+6 IF X="treatment"
SET Y="^start^name^statusName^"
+7 IF X="med"
SET Y="^overallstart^name^vaStatus^"
+8 IF X="consult"
SET Y="^startDate^typeName^statusName^"
+9 IF X="procedure"
SET Y="^dateTime^name^statusName^"
+10 IF X="obs"
SET Y="^observed^typeName^result^"
+11 IF X="lab"
SET Y="^observed^typeName^"
+12 IF X="image"
SET Y="^dateTime^name^statusName^"
+13 IF X="surgery"
SET Y="^dateTime^typeName^statusName^"
+14 IF X="document"
SET Y="^referenceDateTime^localTitle^statusName^"
+15 IF X="mh"
SET Y="^administeredDateTime^name^"
+16 IF X="immunization"
SET Y="^administeredDateTime^name^"
+17 IF X="pov"
SET Y="^entered^name^"
+18 IF X="skin"
SET Y="^entered^name^result^"
+19 IF X="exam"
SET Y="^entered^name^result^"
+20 IF X="cpt"
SET Y="^entered^name^"
+21 IF X="education"
SET Y="^entered^name^result^"
+22 IF X="factor"
SET Y="^entered^name^"
+23 IF X="appointment"
SET Y="^dateTime^typeName^appointmentStatus^"
+24 IF X="visit"
SET Y="^dateTime^typeName^"
+25 IF X="ptf"
SET Y="^arrivalDateTime^icdCode^"
+26 QUIT Y
+27 ;
+28 ;
TEST(FILTER) ;
+1 NEW DONE,OUT
+2 SET DONE=0
+3 FOR
Begin DoDot:1
+4 DO CHECK(.OUT,.FILTER)
+5 HANG 1
WRITE !,$DATA(OUT)
+6 IF $DATA(OUT)>0
SET DONE=1
End DoDot:1
if DONE=1
QUIT
+7 QUIT
