VPRDTST ;SLC/MKB -- Test VistA data XML RPC ;10/18/12 6:26pm
;;1.0;VIRTUAL PATIENT RECORD;**4,5,32,33**;Sep 01, 2011;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; DIC 2051
; DIR 10026
;
EN ; -- test GET^VPRD, write results to screen
N DFN,TYPE,TEXT,CRLF,START,STOP,MAX,ID,IN,OUT,IDX,X,QUIT
F S DFN=$$PATIENT Q:DFN<1 D
. F S TYPE=$$DOMAIN Q:"^"[TYPE D
.. D RPC W !
.. K TEXT,CRLF,START,STOP,MAX,IN,ID,QUIT
Q
;
RPC ; -- get search parameters, run and display
I $$DOC(TYPE) S TEXT=$$SHOW Q:TEXT="^" I 1
E S CRLF=$$NOWRAP Q:CRLF="^"
N DONE S DONE=0
I TYPE'="patient",TYPE'="flag",TYPE'="reminder" D Q:DONE
. S START=$S(TYPE'["insurance":$$START,1:"") I START="^" S DONE=1 Q
. I START S STOP=$$STOP(START) I STOP="^" S DONE=1 Q
. S MAX=$$TOTAL I MAX="^" S DONE=1 Q
. I $$FILTERS(.IN)="^" S DONE=1 Q
. I START="",MAX="",'$D(IN) S ID=$$ITEM S:ID="^" DONE=1
;
Q:DONE
S:$L($G(TEXT)) IN("text")=TEXT
S:$L($G(CRLF)) IN("nowrap")=CRLF
D GET^VPRD(.OUT,+$G(DFN),$G(TYPE),$G(START),$G(STOP),$G(MAX),$G(ID),.IN)
;
S TYPE=$S(TYPE="pharmacy":"med",TYPE="clinicalProcedure":"procedure",1:TYPE)
W ! F IDX=1,2 W !,$G(@OUT@(IDX)) ;version and total
F S IDX=$O(@OUT@(IDX)) Q:IDX<1 D Q:$G(QUIT)
. S X=$G(@OUT@(IDX))
. I X=("<"_TYPE_">") D READ Q:$G(QUIT)
. W !,@OUT@(IDX)
K @OUT
;S IDX=OUT W !
;F S IDX=$Q(@IDX) Q:IDX'?1"^TMP(""VPR"","1.N.E Q:+$P(IDX,",",2)'=$J W !,@IDX
Q
;
READ ; -- continue?
N X K QUIT
W !!,"Press <return> to continue or ^ to exit results ..." R X:DTIME
S:X["^" QUIT=1 W !
Q
;
PATIENT() ; -- select patient
N X,Y,DIC
S DIC=2,DIC(0)="AEQM" D ^DIC
Q Y
;
DOMAIN() ; -- select domain
N X,Y,I,DIR,VPR
S DIR(0)="SAO^",DIR("A")="Select DOMAIN: " D DIRL
F I=1:1 S X=$P($T(TYPE+I),";",3) Q:X=99 S DIR(0)=DIR(0)_$P(X,":",1,2)_";",VPR(+X)=$P(X,":",3)
S DIR("?")="Select the type of clinical data to extract from VistA for this patient"
D ^DIR S:Y Y=VPR(Y)
Q Y
;
TYPE ;;CODE:NAME:TAG
;;1:ALLERGIES/REACTIONS:allergy
;;2:APPOINTMENTS:appointment
;;3:CLINICAL PROCEDURES:clinicalProcedure
;;4:CONSULTS:consult
;;5:DEMOGRAPHICS:patient
;;6:DOCUMENTS:document
;;7:EXAMS:exam
;;8:FUNCTIONAL MEASUREMENTS:fim
;;9:HEALTH FACTORS:factor
;;10:IMMUNIZATIONS:immunization
;;11:INSURANCE:insurancePolicy
;;12:LAB RESULTS:lab
;;13:LABS BY ACCESSION:accession
;;14:LABS BY ORDER:panel
;;15:MEDS (by EXP DT):med
;;16:MEDS (by REL DT):pharmacy
;;17:OBSERVATIONS (CLiO):observation
;;18:ORDERS:order
;;19:PATIENT EDUCATION:educationTopic
;;20:PATIENT RECORD FLAGS:flag
;;21:PROBLEMS:problem
;;22:PROCEDURES (ALL):procedure
;;23:RADIOLOGY EXAMS:radiology
;;24:SKIN TESTS:skinTest
;;25:SURGERIES:surgery
;;26:VISITS:visit
;;27:VITALS:vital
;;28:WELLNESS REMINDERS:reminder
;;99
;
DIRL ; -- set up DIR("L") array
S DIR("L",1)=" 1 ALLERGIES/REACTIONS 15 MEDS (by Expiration Date)"
S DIR("L",2)=" 2 APPOINTMENTS 16 MEDS (by Release Date)"
S DIR("L",3)=" 3 CLINICAL PROCEDURES 17 OBSERVATIONS (CLiO)"
S DIR("L",4)=" 4 CONSULTS 18 ORDERS"
S DIR("L",5)=" 5 DEMOGRAPHICS 19 PATIENT EDUCATION"
S DIR("L",6)=" 6 DOCUMENTS 20 PATIENT RECORD FLAGS"
S DIR("L",7)=" 7 EXAMS 21 PROBLEMS"
S DIR("L",8)=" 8 FUNCTIONAL MEASUREMENTS 22 PROCEDURES (ALL)"
S DIR("L",9)=" 9 HEALTH FACTORS 23 RADIOLOGY EXAMS"
S DIR("L",10)="10 IMMUNIZATIONS 24 SKIN TESTS"
S DIR("L",11)="11 INSURANCE 25 SURGERIES"
S DIR("L",12)="12 LAB RESULTS 26 VISITS"
S DIR("L",13)="13 LABS BY ACCESSION 27 VITALS"
S DIR("L")="14 LABS BY ORDER 28 WELLNESS REMINDERS"
Q
;
DOC(X) ; -- Returns 1 or 0, if type X includes a document
N Y S Y=0
I X="document" S Y=1
I X="accession" S Y=1
I X="visit" S Y=1
I X="surgery" S Y=1
I X="radiology" S Y=1
I X="procedure" S Y=1
I X="clinicalProcedure" S Y=1
I X="consult" S Y=1
I X="fim" S Y=1
Q Y
;
SHOW() ; -- true/false to include body of note
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="YAO",DIR("A")="Include the text of each document? "
S DIR("?")="Enter YES to return the body of the note, or NO to omit"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
NOWRAP() ; -- true/false to include CRLF in $$STRING
I "^allergy^flag^lab^panel^"'[(U_TYPE_U) Q ""
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="YAO",DIR("A")="Preserve breaks in multi-line comments? "
S DIR("?")="Enter YES to preserve the line structure, or NO to wrap the text"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
START() ; -- select a start date
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="DAO^::AEPT",DIR("A")="Select START DATE: "
S DIR("?")="Enter an optional date[.time] to begin searching for data"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
STOP(START) ; -- select a stop date
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="DA^"_START_"::AEPT",DIR("A")="Select STOP DATE: "
S DIR("?")="Enter a date[.time] after the START to end searching for data"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
TOTAL() ; -- select the max# to return
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="NAO^1:9999",DIR("A")="Select TOTAL #items: "
S DIR("?")="Enter an optional maximum number of items to return, up to 9999"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
FILTERS(LIST) ; -- define additional filters for domain
;I "^document^insurancePolicy^lab^accession^panel^med^pharmacy^order^problem^procedure^"'[(U_TYPE_U) S Y="" G FQ
N X,Y,DIR,DUOUT,DTOUT,NAME
F1 S DIR(0)="FAO^1:30",DIR("A")="Select FILTER: "
S DIR("?")="Enter the name of an attribute to filter this domain, where supported."
D ^DIR S:$D(DTOUT) Y="^" I "^^"[Y G FQ
S NAME=$$LOW^XLFSTR(Y) S:NAME="vatype" NAME="vaType"
S DIR("A")=" VALUE: " K X,Y
S DIR("?")="Enter the value of the attribute, to filter this domain."
D ^DIR S:$D(DTOUT) Y="^" I "^^"[Y G FQ
S LIST(NAME)=Y G F1
FQ Q Y
;
ITEM() ; -- select an item ID to return
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="FAO^1:20",DIR("A")="ID: "
S DIR("?")="Enter the id of an item to return."
D ^DIR S:$D(DTOUT) Y="^"
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDTST 6370 printed Nov 22, 2024@17:55 Page 2
VPRDTST ;SLC/MKB -- Test VistA data XML RPC ;10/18/12 6:26pm
+1 ;;1.0;VIRTUAL PATIENT RECORD;**4,5,32,33**;Sep 01, 2011;Build 8
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; DIC 2051
+7 ; DIR 10026
+8 ;
EN ; -- test GET^VPRD, write results to screen
+1 NEW DFN,TYPE,TEXT,CRLF,START,STOP,MAX,ID,IN,OUT,IDX,X,QUIT
+2 FOR
SET DFN=$$PATIENT
if DFN<1
QUIT
Begin DoDot:1
+3 FOR
SET TYPE=$$DOMAIN
if "^"[TYPE
QUIT
Begin DoDot:2
+4 DO RPC
WRITE !
+5 KILL TEXT,CRLF,START,STOP,MAX,IN,ID,QUIT
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
RPC ; -- get search parameters, run and display
+1 IF $$DOC(TYPE)
SET TEXT=$$SHOW
if TEXT="^"
QUIT
IF 1
+2 IF '$TEST
SET CRLF=$$NOWRAP
if CRLF="^"
QUIT
+3 NEW DONE
SET DONE=0
+4 IF TYPE'="patient"
IF TYPE'="flag"
IF TYPE'="reminder"
Begin DoDot:1
+5 SET START=$SELECT(TYPE'["insurance":$$START,1:"")
IF START="^"
SET DONE=1
QUIT
+6 IF START
SET STOP=$$STOP(START)
IF STOP="^"
SET DONE=1
QUIT
+7 SET MAX=$$TOTAL
IF MAX="^"
SET DONE=1
QUIT
+8 IF $$FILTERS(.IN)="^"
SET DONE=1
QUIT
+9 IF START=""
IF MAX=""
IF '$DATA(IN)
SET ID=$$ITEM
if ID="^"
SET DONE=1
End DoDot:1
if DONE
QUIT
+10 ;
+11 if DONE
QUIT
+12 if $LENGTH($GET(TEXT))
SET IN("text")=TEXT
+13 if $LENGTH($GET(CRLF))
SET IN("nowrap")=CRLF
+14 DO GET^VPRD(.OUT,+$GET(DFN),$GET(TYPE),$GET(START),$GET(STOP),$GET(MAX),$GET(ID),.IN)
+15 ;
+16 SET TYPE=$SELECT(TYPE="pharmacy":"med",TYPE="clinicalProcedure":"procedure",1:TYPE)
+17 ;version and total
WRITE !
FOR IDX=1,2
WRITE !,$GET(@OUT@(IDX))
+18 FOR
SET IDX=$ORDER(@OUT@(IDX))
if IDX<1
QUIT
Begin DoDot:1
+19 SET X=$GET(@OUT@(IDX))
+20 IF X=("<"_TYPE_">")
DO READ
if $GET(QUIT)
QUIT
+21 WRITE !,@OUT@(IDX)
End DoDot:1
if $GET(QUIT)
QUIT
+22 KILL @OUT
+23 ;S IDX=OUT W !
+24 ;F S IDX=$Q(@IDX) Q:IDX'?1"^TMP(""VPR"","1.N.E Q:+$P(IDX,",",2)'=$J W !,@IDX
+25 QUIT
+26 ;
READ ; -- continue?
+1 NEW X
KILL QUIT
+2 WRITE !!,"Press <return> to continue or ^ to exit results ..."
READ X:DTIME
+3 if X["^"
SET QUIT=1
WRITE !
+4 QUIT
+5 ;
PATIENT() ; -- select patient
+1 NEW X,Y,DIC
+2 SET DIC=2
SET DIC(0)="AEQM"
DO ^DIC
+3 QUIT Y
+4 ;
DOMAIN() ; -- select domain
+1 NEW X,Y,I,DIR,VPR
+2 SET DIR(0)="SAO^"
SET DIR("A")="Select DOMAIN: "
DO DIRL
+3 FOR I=1:1
SET X=$PIECE($TEXT(TYPE+I),";",3)
if X=99
QUIT
SET DIR(0)=DIR(0)_$PIECE(X,":",1,2)_";"
SET VPR(+X)=$PIECE(X,":",3)
+4 SET DIR("?")="Select the type of clinical data to extract from VistA for this patient"
+5 DO ^DIR
if Y
SET Y=VPR(Y)
+6 QUIT Y
+7 ;
TYPE ;;CODE:NAME:TAG
+1 ;;1:ALLERGIES/REACTIONS:allergy
+2 ;;2:APPOINTMENTS:appointment
+3 ;;3:CLINICAL PROCEDURES:clinicalProcedure
+4 ;;4:CONSULTS:consult
+5 ;;5:DEMOGRAPHICS:patient
+6 ;;6:DOCUMENTS:document
+7 ;;7:EXAMS:exam
+8 ;;8:FUNCTIONAL MEASUREMENTS:fim
+9 ;;9:HEALTH FACTORS:factor
+10 ;;10:IMMUNIZATIONS:immunization
+11 ;;11:INSURANCE:insurancePolicy
+12 ;;12:LAB RESULTS:lab
+13 ;;13:LABS BY ACCESSION:accession
+14 ;;14:LABS BY ORDER:panel
+15 ;;15:MEDS (by EXP DT):med
+16 ;;16:MEDS (by REL DT):pharmacy
+17 ;;17:OBSERVATIONS (CLiO):observation
+18 ;;18:ORDERS:order
+19 ;;19:PATIENT EDUCATION:educationTopic
+20 ;;20:PATIENT RECORD FLAGS:flag
+21 ;;21:PROBLEMS:problem
+22 ;;22:PROCEDURES (ALL):procedure
+23 ;;23:RADIOLOGY EXAMS:radiology
+24 ;;24:SKIN TESTS:skinTest
+25 ;;25:SURGERIES:surgery
+26 ;;26:VISITS:visit
+27 ;;27:VITALS:vital
+28 ;;28:WELLNESS REMINDERS:reminder
+29 ;;99
+30 ;
DIRL ; -- set up DIR("L") array
+1 SET DIR("L",1)=" 1 ALLERGIES/REACTIONS 15 MEDS (by Expiration Date)"
+2 SET DIR("L",2)=" 2 APPOINTMENTS 16 MEDS (by Release Date)"
+3 SET DIR("L",3)=" 3 CLINICAL PROCEDURES 17 OBSERVATIONS (CLiO)"
+4 SET DIR("L",4)=" 4 CONSULTS 18 ORDERS"
+5 SET DIR("L",5)=" 5 DEMOGRAPHICS 19 PATIENT EDUCATION"
+6 SET DIR("L",6)=" 6 DOCUMENTS 20 PATIENT RECORD FLAGS"
+7 SET DIR("L",7)=" 7 EXAMS 21 PROBLEMS"
+8 SET DIR("L",8)=" 8 FUNCTIONAL MEASUREMENTS 22 PROCEDURES (ALL)"
+9 SET DIR("L",9)=" 9 HEALTH FACTORS 23 RADIOLOGY EXAMS"
+10 SET DIR("L",10)="10 IMMUNIZATIONS 24 SKIN TESTS"
+11 SET DIR("L",11)="11 INSURANCE 25 SURGERIES"
+12 SET DIR("L",12)="12 LAB RESULTS 26 VISITS"
+13 SET DIR("L",13)="13 LABS BY ACCESSION 27 VITALS"
+14 SET DIR("L")="14 LABS BY ORDER 28 WELLNESS REMINDERS"
+15 QUIT
+16 ;
DOC(X) ; -- Returns 1 or 0, if type X includes a document
+1 NEW Y
SET Y=0
+2 IF X="document"
SET Y=1
+3 IF X="accession"
SET Y=1
+4 IF X="visit"
SET Y=1
+5 IF X="surgery"
SET Y=1
+6 IF X="radiology"
SET Y=1
+7 IF X="procedure"
SET Y=1
+8 IF X="clinicalProcedure"
SET Y=1
+9 IF X="consult"
SET Y=1
+10 IF X="fim"
SET Y=1
+11 QUIT Y
+12 ;
SHOW() ; -- true/false to include body of note
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="YAO"
SET DIR("A")="Include the text of each document? "
+3 SET DIR("?")="Enter YES to return the body of the note, or NO to omit"
+4 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+5 QUIT Y
+6 ;
NOWRAP() ; -- true/false to include CRLF in $$STRING
+1 IF "^allergy^flag^lab^panel^"'[(U_TYPE_U)
QUIT ""
+2 NEW X,Y,DIR,DUOUT,DTOUT
+3 SET DIR(0)="YAO"
SET DIR("A")="Preserve breaks in multi-line comments? "
+4 SET DIR("?")="Enter YES to preserve the line structure, or NO to wrap the text"
+5 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+6 QUIT Y
+7 ;
START() ; -- select a start date
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="DAO^::AEPT"
SET DIR("A")="Select START DATE: "
+3 SET DIR("?")="Enter an optional date[.time] to begin searching for data"
+4 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+5 QUIT Y
+6 ;
STOP(START) ; -- select a stop date
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="DA^"_START_"::AEPT"
SET DIR("A")="Select STOP DATE: "
+3 SET DIR("?")="Enter a date[.time] after the START to end searching for data"
+4 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+5 QUIT Y
+6 ;
TOTAL() ; -- select the max# to return
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="NAO^1:9999"
SET DIR("A")="Select TOTAL #items: "
+3 SET DIR("?")="Enter an optional maximum number of items to return, up to 9999"
+4 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+5 QUIT Y
+6 ;
FILTERS(LIST) ; -- define additional filters for domain
+1 ;I "^document^insurancePolicy^lab^accession^panel^med^pharmacy^order^problem^procedure^"'[(U_TYPE_U) S Y="" G FQ
+2 NEW X,Y,DIR,DUOUT,DTOUT,NAME
F1 SET DIR(0)="FAO^1:30"
SET DIR("A")="Select FILTER: "
+1 SET DIR("?")="Enter the name of an attribute to filter this domain, where supported."
+2 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
IF "^^"[Y
GOTO FQ
+3 SET NAME=$$LOW^XLFSTR(Y)
if NAME="vatype"
SET NAME="vaType"
+4 SET DIR("A")=" VALUE: "
KILL X,Y
+5 SET DIR("?")="Enter the value of the attribute, to filter this domain."
+6 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
IF "^^"[Y
GOTO FQ
+7 SET LIST(NAME)=Y
GOTO F1
FQ QUIT Y
+1 ;
ITEM() ; -- select an item ID to return
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="FAO^1:20"
SET DIR("A")="ID: "
+3 SET DIR("?")="Enter the id of an item to return."
+4 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+5 QUIT Y
