- 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 Feb 19, 2025@00:10:49 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