VBECLU ;HIOFO/bnt-VBECS Patient Lookup Utility ; 9/8/05 12:43pm
;;2.0;VBEC;**1**;Jun 05, 2015;Build 13
;
; Note: This routine supports data exchange with an FDA registered
; medical device. As such, it may not be changed in any way without
; prior written approval from the medical device manufacturer.
;
; Integration Agreements:
; Call to GETICN^MPIF001 is supported by IA: 2701
; Reference to $$FMTHL7^XLFDT supported by IA #10103
; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
; Reference to DT^DICRW supported by IA #10005
; Call to $$UP^XLFSTR is supported by IA: 10104
; Call to ^DIM is supported by IA: 10016
; Call to ^VA(200 is supported by IA: 10060
; Reference to FIND^DIC supported by IA #2051
;
;
SET X="You Can't Enter VBECLU at top of routine!"
QUIT
;
SEARCH(RESULT,PARAMS) ; -- return patient data in XML format
; -- RPC: VBEC PATIENT LOOKUP SEARCH
; --
; -- input PARAMS ARRAY
; PARAMS("SEARCH_TYPE") = "NAME", "SSN", ICN, SSN4
; PARAMS("SEARCH_VALUE") = value to search for.
;
NEW I,X,Y,VBECPCNT,VBECLINE,VBECRSLT,SEARCH,VALUE,FILTER,FILTERV,BDATE,EDATE
NEW MAXSIZE,MAXSIZRE,LINENO,DELIM,MSCREEN,RESTRICT,ERRMSG
IF '$D(DT) D DT^DICRW
;KILL RESULT
SET VBECPCNT=0
SET VBECLINE=0
SET VBECRSLT="^TMP(""VBEC-PLU-SEARCH"",$J)"
SET RESULT=$NA(@VBECRSLT)
K @RESULT
;
SET SEARCH=$$UP^XLFSTR($GET(PARAMS("SEARCH_TYPE")))
SET VALUE=$$UP^XLFSTR($GET(PARAMS("SEARCH_VALUE")))
SET MAXSIZE=+$GET(PARAMS("MAX_PATIENTS"),50),MAXSIZRE=0
IF (MAXSIZE<5) SET MAXSIZE=5
IF (MAXSIZE>100) SET MAXSIZE=100
;
SET FILTER=$$UP^XLFSTR($GET(PARAMS("FILTER_TYPE")))
SET FILTERV=$G(PARAMS("FILTER_VALUE"))
SET BDATE=$G(PARAMS("CLINIC_STARTDATE"))
SET EDATE=$G(PARAMS("CLINIC_ENDDATE"))
SET MSCREEN=$$UP^XLFSTR($G(PARAMS("MSCREEN")))
IF MSCREEN'="" DO
. SET X=MSCREEN D ^DIM IF $D(X)=0 SET MSCREEN="" SET ERRMSG="MSCREEN is invalid M code" Q
. IF $E(MSCREEN)'="I" SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, must start with an If statement." Q
. IF MSCREEN[" S "!(MSCREEN[" SET ")!(MSCREEN[" S:")!(MSCREEN["SET:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not set values." Q
. IF MSCREEN[" K "!(MSCREEN[" KILL ")!(MSCREEN[" K:")!(MSCREEN["SET:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not kill values." Q
. IF MSCREEN[" W "!(MSCREEN[" WRITE ")!(MSCREEN[" W:")!(MSCREEN["WRITE:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not WRITE." Q
SET DELIM=$G(PARAMS("DELIMITER"),",") ; Defaults to comma to support old way.
;
SET RESTRICT=$G(^VA(200,+$G(DUZ),101))
IF +RESTRICT DO
. S CODE="I $D(^OR(100.21,"_$P(RESTRICT,"^",2)_",10,""B"",+$G(DFN)_"";DPT(""))"
. IF MSCREEN'="" S MSCREEN=" "_CODE Q
. IF MSCREEN="" S MSCREEN=CODE
;
IF (FILTER'=""),(FILTERV'="") DO BYFILTER^VBECLU0(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM) GOTO DONE
;
IF (SEARCH="NAME")!(SEARCH="SSN")!(SEARCH="ICN")!(SEARCH="SSN4") D BYNAME
ELSE DO GOTO DONE
. DO ADD("<record count='0'>")
. DO ADD("<error message='Searching for patients by "_SEARCH_" not yet implemented!'></error>")
QUIT
;
BYNAME ;
NEW FULLCNT,VBECPCNT,VBEC,NODE,DFN,XREF
;; copied From scutbk11
;; DO FIND^DIC(2,,".01;.03;.363;.09","PS",VALUE,300,"B^BS^BS5^SSN")
;
IF VALUE="" DO GOTO DONE
. DO ADD("<record count='0'>")
. DO ADD("<error message='Not Enough Information Provided to Search for Patients for Search Type = """_SEARCH_"""'></error>")
;
IF SEARCH="NAME" SET XREF="B",VALUE=$TR(VALUE," ","") ;REMOVE SPACES
IF SEARCH="SSN" SET XREF="BS^SSN^CN^RM",VALUE=$TR(VALUE," -","") ; REMOVE DASHES AND SPACES
IF SEARCH="SSN4" SET XREF="BS5" DO
. IF $L(VALUE)>5 SET VALUE=$E(VALUE,1,5) ; can't exceed 5 characters, if P for psuedo on end take it off.
IF SEARCH="ICN" SET XREF="AICN"
DO FIND^DIC(2,,".01;.03;.09","MPS",VALUE,,XREF)
IF $G(DIERR) DO GOTO DONE
. DO ADD("<record count='0'>")
. DO ADD("<error message='Error occured in VistA during patient lookup'></error>")
. DO CLEAN^DILF
SET FULLCNT=+$G(^TMP("DILIST",$J,0))
DO ADD("<record count='0'>")
SET LINENO=VBECLINE
;
SET VBECPCNT=0
FOR VBEC=1:1:FULLCNT D ;Q:$$STOP^XOBVLIB()
. SET NODE=^TMP("DILIST",$J,VBEC,0)
. SET DFN=$P(NODE,"^",1)
. D PTDATA(+NODE,.VBECPCNT)
I $G(ERRMSG)]"" D
. DO ADD("<error message=''>"_$G(ERRMSG)_"</error>")
;IF ($G(MAXSIZRE)<1) DO ADD("<maximum message=''></maximum>")
SET @VBECRSLT@(LINENO)="<record count='"_VBECPCNT_"'>"
;
DONE ;
DO ADD("</record>")
IF 1
QUIT
;
EXIT ;
QUIT
;
PTDATA(DFN,VBECPCNT) ;
NEW I,DONE,LINE,ALIAS,NAME,PTNAME,DOB,DOD,SSN,TYPE,GENDER,ICN,PRIM,SC,SCPER,VET,WARD,ROOMBED,SENSITIV,DOBCODE,FNAME,LNAME,MI,X1,X2
;IF VBECPCNT>(MAXSIZE-1) DO MAXOUT QUIT
IF (MSCREEN'="") X MSCREEN I '$T Q
SET VBECPCNT=VBECPCNT+1
;SET LINE="<patient number='"_VBECPCNT_"' dfn='"_DFN_"'"
DO ADD("<Patient><Number>"_VBECPCNT_"</Number><VistaPatientID>"_DFN_"</VistaPatientID>")
;
SET PTNAME=$P(^DPT(DFN,0),"^",1)
SET X1=$P(PTNAME,",",2),X2=$L(X1," "),MI=""
IF X2 SET MI=$P(X1," ",2),X1=$P(X1," ")
SET FNAME=$$CHARCHK^XOBVLIB(X1),MI=$$CHARCHK^XOBVLIB(MI)
SET LNAME=$$CHARCHK^XOBVLIB($P(PTNAME,","))
;
; -- REQUIRED COMPONENTS
SET SENSITIV=$S($P($G(^DGSL(38.1,DFN,0)),"^",2)=1:"true",1:"false")
; Get DOB and determine if month or day is zero and add DOB Code.
SET DOB=$$FMTHL7^XLFDT($P($G(^DPT(DFN,0)),"^",3)),DOBCODE="V"
; Get Date Of Death
SET DOD=$$CHARCHK^XOBVLIB($$FMTHL7^XLFDT($P($G(^DPT(DFN,.35)),"^")))
IF $E(DOB,5,8)["00" DO
. SET:$E(DOB,5,8)="0000" $E(DOB,5,8)="0101",DOBCODE="B" Q ; Both zero
. SET:$E(DOB,5,6)="00" $E(DOB,5,6)="01",DOBCODE="M" Q ; Month zero
. SET:$E(DOB,6,8)="00" $E(DOB,6,8)="01",DOBCODE="D" Q ; day zero
S DOB=$$CHARCHK^XOBVLIB(DOB)
SET SSN=$$CHARCHK^XOBVLIB($P($G(^DPT(DFN,0)),"^",9))
;SET LINE=LINE_" sensitive='"_SENSITIV_"' name='"_NAME_"' dob='"_DOB_"' ssn='"_SSN_"' "
DO ADD("<PatientLastName>"_LNAME_"</PatientLastName><PatientFirstName>"_FNAME_"</PatientFirstName><PatientMiddleName>"_MI_"</PatientMiddleName>")
D NAMECOMP^VBECLU0(DFN) ;RLM 112917
DO ADD("<Sensitive>"_SENSITIV_"</Sensitive><PatientDOB>"_DOB_"</PatientDOB><PatientDOBCode>"_DOBCODE_"</PatientDOBCode><PatientSSN>"_SSN_"</PatientSSN>")
DO ADD("<PatientDeathDate>"_DOD_"</PatientDeathDate>")
;
; -- OPTIONAL COMPONENTS
;Patient Type (391)
SET TYPE=$$CHARCHK^XOBVLIB($P($G(^DG(391,+$G(^DPT(DFN,"TYPE")),0)),"^",1))
;
;gender
SET GENDER=$$CHARCHK^XOBVLIB($P($G(^DPT(DFN,0)),"^",2))
;
;icn
SET ICN=$P($G(^DPT(DFN,"MPI")),"^",1)
; This API sets the ICN checksum.
SET ICN=$$GETICN^MPIF001(DFN)
IF +ICN<0 SET ICN=$$ICNLC^MPIF001(DFN)
;
;Primary Eligibility(.361)
SET PRIM=$$PRIM(DFN)
;
SET SC=$P($G(^DPT(DFN,.3)),"^",1,2) ;Is Service Connected (.301) %=.302
SET SCPER=$P(SC,"^",2)
IF $P(SC,"^",1)="Y" SET SC="true"
IF $P(SC,"^",1)="N" SET SC="false"
;
SET VET=$P($G(^DPT(DFN,"VET")),"^",1) ;Veteran Status (1901)
IF VET="Y" SET VET="true"
IF VET="N" SET VET="false"
;
SET WARD=$$CHARCHK^XOBVLIB($E($G(^DPT(DFN,.1)),1,30))
SET ROOMBED=$$CHARCHK^XOBVLIB($P($G(^DPT(DFN,.101)),"^",1))
;
;SET LINE=LINE_" type='"_TYPE_"' primaryeligibility='"_PRIM_"' serviceconnected='"_SC_"' scpercent='"_SCPER_"'"
DO ADD("<Type>"_TYPE_"</Type><PrimaryEligibility>"_PRIM_"</PrimaryEligibility><ServiceConnected>"_SC_"</ServiceConnected><ScPercent>"_SCPER_"</ScPercent>")
;SET LINE=LINE_" gender='"_GENDER_"' icn='"_ICN_"' veteran='"_VET_"' ward='"_WARD_"' roombed='"_ROOMBED_"'></patient>"
DO ADD("<PatientSexCode>"_GENDER_"</PatientSexCode><PatientICN>"_ICN_"</PatientICN><Veteran>"_VET_"</Veteran><PatientLocation>"_WARD_"</PatientLocation><PatientRoomBed>"_ROOMBED_"</PatientRoomBed></Patient>")
;
;DO ADD(LINE)
;DO NAMECOMP^VBECLU0(DFN,VBECPCNT)
;
QUIT
;
MAXOUT ;
IF $G(MAXSIZRE)<1 DO ADD("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
SET MAXSIZRE=1
QUIT
;
PRIM(DFN) ; -- returns print name from file 8.1
NEW PRIM1
SET PRIM1=$P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),"^",9) ; station entry
Q $$CHARCHK^XOBVLIB($P($G(^DIC(8.1,+PRIM1,0)),"^",6)) ; mas entry
;
ADD(STR) ; -- add string to array
SET VBECLINE=VBECLINE+1
SET @VBECRSLT@(VBECLINE)=STR
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECLU 8341 printed Nov 22, 2024@17:54:12 Page 2
VBECLU ;HIOFO/bnt-VBECS Patient Lookup Utility ; 9/8/05 12:43pm
+1 ;;2.0;VBEC;**1**;Jun 05, 2015;Build 13
+2 ;
+3 ; Note: This routine supports data exchange with an FDA registered
+4 ; medical device. As such, it may not be changed in any way without
+5 ; prior written approval from the medical device manufacturer.
+6 ;
+7 ; Integration Agreements:
+8 ; Call to GETICN^MPIF001 is supported by IA: 2701
+9 ; Reference to $$FMTHL7^XLFDT supported by IA #10103
+10 ; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
+11 ; Reference to DT^DICRW supported by IA #10005
+12 ; Call to $$UP^XLFSTR is supported by IA: 10104
+13 ; Call to ^DIM is supported by IA: 10016
+14 ; Call to ^VA(200 is supported by IA: 10060
+15 ; Reference to FIND^DIC supported by IA #2051
+16 ;
+17 ;
+18 SET X="You Can't Enter VBECLU at top of routine!"
+19 QUIT
+20 ;
SEARCH(RESULT,PARAMS) ; -- return patient data in XML format
+1 ; -- RPC: VBEC PATIENT LOOKUP SEARCH
+2 ; --
+3 ; -- input PARAMS ARRAY
+4 ; PARAMS("SEARCH_TYPE") = "NAME", "SSN", ICN, SSN4
+5 ; PARAMS("SEARCH_VALUE") = value to search for.
+6 ;
+7 NEW I,X,Y,VBECPCNT,VBECLINE,VBECRSLT,SEARCH,VALUE,FILTER,FILTERV,BDATE,EDATE
+8 NEW MAXSIZE,MAXSIZRE,LINENO,DELIM,MSCREEN,RESTRICT,ERRMSG
+9 IF '$DATA(DT)
DO DT^DICRW
+10 ;KILL RESULT
+11 SET VBECPCNT=0
+12 SET VBECLINE=0
+13 SET VBECRSLT="^TMP(""VBEC-PLU-SEARCH"",$J)"
+14 SET RESULT=$NAME(@VBECRSLT)
+15 KILL @RESULT
+16 ;
+17 SET SEARCH=$$UP^XLFSTR($GET(PARAMS("SEARCH_TYPE")))
+18 SET VALUE=$$UP^XLFSTR($GET(PARAMS("SEARCH_VALUE")))
+19 SET MAXSIZE=+$GET(PARAMS("MAX_PATIENTS"),50)
SET MAXSIZRE=0
+20 IF (MAXSIZE<5)
SET MAXSIZE=5
+21 IF (MAXSIZE>100)
SET MAXSIZE=100
+22 ;
+23 SET FILTER=$$UP^XLFSTR($GET(PARAMS("FILTER_TYPE")))
+24 SET FILTERV=$GET(PARAMS("FILTER_VALUE"))
+25 SET BDATE=$GET(PARAMS("CLINIC_STARTDATE"))
+26 SET EDATE=$GET(PARAMS("CLINIC_ENDDATE"))
+27 SET MSCREEN=$$UP^XLFSTR($GET(PARAMS("MSCREEN")))
+28 IF MSCREEN'=""
Begin DoDot:1
+29 SET X=MSCREEN
DO ^DIM
IF $DATA(X)=0
SET MSCREEN=""
SET ERRMSG="MSCREEN is invalid M code"
QUIT
+30 IF $EXTRACT(MSCREEN)'="I"
SET MSCREEN=""
SET ERRMSG="MSCREEN Deleted, must start with an If statement."
QUIT
+31 IF MSCREEN[" S "!(MSCREEN[" SET ")!(MSCREEN[" S:")!(MSCREEN["SET:")
SET MSCREEN=""
SET ERRMSG="MSCREEN Deleted, can not set values."
QUIT
+32 IF MSCREEN[" K "!(MSCREEN[" KILL ")!(MSCREEN[" K:")!(MSCREEN["SET:")
SET MSCREEN=""
SET ERRMSG="MSCREEN Deleted, can not kill values."
QUIT
+33 IF MSCREEN[" W "!(MSCREEN[" WRITE ")!(MSCREEN[" W:")!(MSCREEN["WRITE:")
SET MSCREEN=""
SET ERRMSG="MSCREEN Deleted, can not WRITE."
QUIT
End DoDot:1
+34 ; Defaults to comma to support old way.
SET DELIM=$GET(PARAMS("DELIMITER"),",")
+35 ;
+36 SET RESTRICT=$GET(^VA(200,+$GET(DUZ),101))
+37 IF +RESTRICT
Begin DoDot:1
+38 SET CODE="I $D(^OR(100.21,"_$PIECE(RESTRICT,"^",2)_",10,""B"",+$G(DFN)_"";DPT(""))"
+39 IF MSCREEN'=""
SET MSCREEN=" "_CODE
QUIT
+40 IF MSCREEN=""
SET MSCREEN=CODE
End DoDot:1
+41 ;
+42 IF (FILTER'="")
IF (FILTERV'="")
DO BYFILTER^VBECLU0(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM)
GOTO DONE
+43 ;
+44 IF (SEARCH="NAME")!(SEARCH="SSN")!(SEARCH="ICN")!(SEARCH="SSN4")
DO BYNAME
+45 IF '$TEST
Begin DoDot:1
+46 DO ADD("<record count='0'>")
+47 DO ADD("<error message='Searching for patients by "_SEARCH_" not yet implemented!'></error>")
End DoDot:1
GOTO DONE
+48 QUIT
+49 ;
BYNAME ;
+1 NEW FULLCNT,VBECPCNT,VBEC,NODE,DFN,XREF
+2 ;; copied From scutbk11
+3 ;; DO FIND^DIC(2,,".01;.03;.363;.09","PS",VALUE,300,"B^BS^BS5^SSN")
+4 ;
+5 IF VALUE=""
Begin DoDot:1
+6 DO ADD("<record count='0'>")
+7 DO ADD("<error message='Not Enough Information Provided to Search for Patients for Search Type = """_SEARCH_"""'></error>")
End DoDot:1
GOTO DONE
+8 ;
+9 ;REMOVE SPACES
IF SEARCH="NAME"
SET XREF="B"
SET VALUE=$TRANSLATE(VALUE," ","")
+10 ; REMOVE DASHES AND SPACES
IF SEARCH="SSN"
SET XREF="BS^SSN^CN^RM"
SET VALUE=$TRANSLATE(VALUE," -","")
+11 IF SEARCH="SSN4"
SET XREF="BS5"
Begin DoDot:1
+12 ; can't exceed 5 characters, if P for psuedo on end take it off.
IF $LENGTH(VALUE)>5
SET VALUE=$EXTRACT(VALUE,1,5)
End DoDot:1
+13 IF SEARCH="ICN"
SET XREF="AICN"
+14 DO FIND^DIC(2,,".01;.03;.09","MPS",VALUE,,XREF)
+15 IF $GET(DIERR)
Begin DoDot:1
+16 DO ADD("<record count='0'>")
+17 DO ADD("<error message='Error occured in VistA during patient lookup'></error>")
+18 DO CLEAN^DILF
End DoDot:1
GOTO DONE
+19 SET FULLCNT=+$GET(^TMP("DILIST",$JOB,0))
+20 DO ADD("<record count='0'>")
+21 SET LINENO=VBECLINE
+22 ;
+23 SET VBECPCNT=0
+24 ;Q:$$STOP^XOBVLIB()
FOR VBEC=1:1:FULLCNT
Begin DoDot:1
+25 SET NODE=^TMP("DILIST",$JOB,VBEC,0)
+26 SET DFN=$PIECE(NODE,"^",1)
+27 DO PTDATA(+NODE,.VBECPCNT)
End DoDot:1
+28 IF $GET(ERRMSG)]""
Begin DoDot:1
+29 DO ADD("<error message=''>"_$GET(ERRMSG)_"</error>")
End DoDot:1
+30 ;IF ($G(MAXSIZRE)<1) DO ADD("<maximum message=''></maximum>")
+31 SET @VBECRSLT@(LINENO)="<record count='"_VBECPCNT_"'>"
+32 ;
DONE ;
+1 DO ADD("</record>")
+2 IF 1
+3 QUIT
+4 ;
EXIT ;
+1 QUIT
+2 ;
PTDATA(DFN,VBECPCNT) ;
+1 NEW I,DONE,LINE,ALIAS,NAME,PTNAME,DOB,DOD,SSN,TYPE,GENDER,ICN,PRIM,SC,SCPER,VET,WARD,ROOMBED,SENSITIV,DOBCODE,FNAME,LNAME,MI,X1,X2
+2 ;IF VBECPCNT>(MAXSIZE-1) DO MAXOUT QUIT
+3 IF (MSCREEN'="")
XECUTE MSCREEN
IF '$TEST
QUIT
+4 SET VBECPCNT=VBECPCNT+1
+5 ;SET LINE="<patient number='"_VBECPCNT_"' dfn='"_DFN_"'"
+6 DO ADD("<Patient><Number>"_VBECPCNT_"</Number><VistaPatientID>"_DFN_"</VistaPatientID>")
+7 ;
+8 SET PTNAME=$PIECE(^DPT(DFN,0),"^",1)
+9 SET X1=$PIECE(PTNAME,",",2)
SET X2=$LENGTH(X1," ")
SET MI=""
+10 IF X2
SET MI=$PIECE(X1," ",2)
SET X1=$PIECE(X1," ")
+11 SET FNAME=$$CHARCHK^XOBVLIB(X1)
SET MI=$$CHARCHK^XOBVLIB(MI)
+12 SET LNAME=$$CHARCHK^XOBVLIB($PIECE(PTNAME,","))
+13 ;
+14 ; -- REQUIRED COMPONENTS
+15 SET SENSITIV=$SELECT($PIECE($GET(^DGSL(38.1,DFN,0)),"^",2)=1:"true",1:"false")
+16 ; Get DOB and determine if month or day is zero and add DOB Code.
+17 SET DOB=$$FMTHL7^XLFDT($PIECE($GET(^DPT(DFN,0)),"^",3))
SET DOBCODE="V"
+18 ; Get Date Of Death
+19 SET DOD=$$CHARCHK^XOBVLIB($$FMTHL7^XLFDT($PIECE($GET(^DPT(DFN,.35)),"^")))
+20 IF $EXTRACT(DOB,5,8)["00"
Begin DoDot:1
+21 ; Both zero
if $EXTRACT(DOB,5,8)="0000"
SET $EXTRACT(DOB,5,8)="0101"
SET DOBCODE="B"
QUIT
+22 ; Month zero
if $EXTRACT(DOB,5,6)="00"
SET $EXTRACT(DOB,5,6)="01"
SET DOBCODE="M"
QUIT
+23 ; day zero
if $EXTRACT(DOB,6,8)="00"
SET $EXTRACT(DOB,6,8)="01"
SET DOBCODE="D"
QUIT
End DoDot:1
+24 SET DOB=$$CHARCHK^XOBVLIB(DOB)
+25 SET SSN=$$CHARCHK^XOBVLIB($PIECE($GET(^DPT(DFN,0)),"^",9))
+26 ;SET LINE=LINE_" sensitive='"_SENSITIV_"' name='"_NAME_"' dob='"_DOB_"' ssn='"_SSN_"' "
+27 DO ADD("<PatientLastName>"_LNAME_"</PatientLastName><PatientFirstName>"_FNAME_"</PatientFirstName><PatientMiddleName>"_MI_"</PatientMiddleName>")
+28 ;RLM 112917
DO NAMECOMP^VBECLU0(DFN)
+29 DO ADD("<Sensitive>"_SENSITIV_"</Sensitive><PatientDOB>"_DOB_"</PatientDOB><PatientDOBCode>"_DOBCODE_"</PatientDOBCode><PatientSSN>"_SSN_"</PatientSSN>")
+30 DO ADD("<PatientDeathDate>"_DOD_"</PatientDeathDate>")
+31 ;
+32 ; -- OPTIONAL COMPONENTS
+33 ;Patient Type (391)
+34 SET TYPE=$$CHARCHK^XOBVLIB($PIECE($GET(^DG(391,+$GET(^DPT(DFN,"TYPE")),0)),"^",1))
+35 ;
+36 ;gender
+37 SET GENDER=$$CHARCHK^XOBVLIB($PIECE($GET(^DPT(DFN,0)),"^",2))
+38 ;
+39 ;icn
+40 SET ICN=$PIECE($GET(^DPT(DFN,"MPI")),"^",1)
+41 ; This API sets the ICN checksum.
+42 SET ICN=$$GETICN^MPIF001(DFN)
+43 IF +ICN<0
SET ICN=$$ICNLC^MPIF001(DFN)
+44 ;
+45 ;Primary Eligibility(.361)
+46 SET PRIM=$$PRIM(DFN)
+47 ;
+48 ;Is Service Connected (.301) %=.302
SET SC=$PIECE($GET(^DPT(DFN,.3)),"^",1,2)
+49 SET SCPER=$PIECE(SC,"^",2)
+50 IF $PIECE(SC,"^",1)="Y"
SET SC="true"
+51 IF $PIECE(SC,"^",1)="N"
SET SC="false"
+52 ;
+53 ;Veteran Status (1901)
SET VET=$PIECE($GET(^DPT(DFN,"VET")),"^",1)
+54 IF VET="Y"
SET VET="true"
+55 IF VET="N"
SET VET="false"
+56 ;
+57 SET WARD=$$CHARCHK^XOBVLIB($EXTRACT($GET(^DPT(DFN,.1)),1,30))
+58 SET ROOMBED=$$CHARCHK^XOBVLIB($PIECE($GET(^DPT(DFN,.101)),"^",1))
+59 ;
+60 ;SET LINE=LINE_" type='"_TYPE_"' primaryeligibility='"_PRIM_"' serviceconnected='"_SC_"' scpercent='"_SCPER_"'"
+61 DO ADD("<Type>"_TYPE_"</Type><PrimaryEligibility>"_PRIM_"</PrimaryEligibility><ServiceConnected>"_SC_"</ServiceConnected><ScPercent>"_SCPER_"</ScPercent>")
+62 ;SET LINE=LINE_" gender='"_GENDER_"' icn='"_ICN_"' veteran='"_VET_"' ward='"_WARD_"' roombed='"_ROOMBED_"'></patient>"
+63 DO ADD("<PatientSexCode>"_GENDER_"</PatientSexCode><PatientICN>"_ICN_"</PatientICN><Veteran>"_VET_"</Veteran><PatientLocation>"_WARD_"</PatientLocation><PatientRoomBed>"_ROOMBED_"</PatientRoomBed></Patient>")
+64 ;
+65 ;DO ADD(LINE)
+66 ;DO NAMECOMP^VBECLU0(DFN,VBECPCNT)
+67 ;
+68 QUIT
+69 ;
MAXOUT ;
+1 IF $GET(MAXSIZRE)<1
DO ADD("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
+2 SET MAXSIZRE=1
+3 QUIT
+4 ;
PRIM(DFN) ; -- returns print name from file 8.1
+1 NEW PRIM1
+2 ; station entry
SET PRIM1=$PIECE($GET(^DIC(8,+$GET(^DPT(DFN,.36)),0)),"^",9)
+3 ; mas entry
QUIT $$CHARCHK^XOBVLIB($PIECE($GET(^DIC(8.1,+PRIM1,0)),"^",6))
+4 ;
ADD(STR) ; -- add string to array
+1 SET VBECLINE=VBECLINE+1
+2 SET @VBECRSLT@(VBECLINE)=STR
+3 QUIT
