Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VBECLU

VBECLU.m

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