PSJPAD7U ;BIR/JCH-HL7 RECEIVER OMS PADE POCKET ACTIVITY ;9/3/15 1:34 PM
;;5.0;INPATIENT MEDICATIONS ;**317**;16 DEC 97;Build 130
;
; Reference to ^HLPRS is supported by DBIA #4742
; Reference to ^XLFDT is supported by DBIA #10103.
; Reference to ^XLFMTH is supported by DBIA #10105.
; Reference to ^XMD is supported by DBIA #10070.
;
Q ;Direct entry not supported
;
LOADMSG(PSJOMS,PSJMSH,PSJERR) ; Load HL7 message into temporary global for processing
;This subroutine assumes that all VistA HL7 environment variables are properly initialized
N HEADER,OK,SEG,HLHDRO,HLMSG,HLMTIEN,HLMTIENS,HLVER
S PSJERR=""
S OK=$$STARTMSG^HLPRS(.HLMSG,+PSJMSH,.HEADER) I 'OK D Q
.S PSJERR="MSH - No header message defined"
.D ERROR^PSJPAD7U(PSJERR,1) Q
;
;begin parsing of segments and validate
D MSH
F Q:'$$NEXTSEG^HLPRS(.HLMSG,.SEG) D DECODE
Q
;
DECODE ; parse out data from segments
K FIELD S FIELD(0)=""
S FIELD(0)=$G(SEG("SEGMENT TYPE"))
I (",MSH,ORC,PID,PV1,RQD,ZPM,NTE,")[(","_FIELD(0)_",") D @FIELD(0)
Q
;
MSH ; Get Message Identifiers
S PSJOMS("HLMTIEN")=$G(HLMTIEN)
S PSJOMS("HLMTIENS")=$G(HLMTIENS)
S PSJOMS("HLVER")=$G(HL("VER"))
Q
;
PID ; Parse PID segment
N II,PATICN,PATSSN,PATDFN,PATID,QQ
S PSJOMS("PID")=$G(SEG(0))
S PSJOMS("PTID")=$G(SEG(3,1,1,1))
;
F QQ=1:1:4 S PATID=$G(SEG(3,QQ,3,1)) D
.S:PATID="NI" PATICN=$G(SEG(3,QQ,1,1))
.I PATID="SS" S PATSSN=$G(SEG(3,QQ,1,1))
.S:PATID="PI"!(PATID="M10") PATDFN=$G(SEG(3,QQ,1,1))
I PATID="" F QQ=1:1:4 S PATID=$G(SEG(3,3,QQ,1)) D
.S:PATID="NI" PATICN=$G(SEG(3,1,QQ,1))
.I PATID="SS" S PATSSN=$G(SEG(3,1,QQ,1))
.S:PATID="PI"!(PATID="M10") PATDFN=$G(SEG(3,1,QQ,1))
; If it's not in PATIENT (#2) file, it's not a valid DFN
I $G(PATDFN),'$D(^DPT(PATDFN,0)) S PATDFN=0
S:$G(PATDFN) PSJOMS("DFN")=PATDFN
; Get patient SSN from PID.19 Patient SSN
I '$G(PATSSN) S PATSSN=$TR($G(SEG(19,1,1,1)),"-")
; If no SSN in PID.19, check PID.18
I '$G(PATSSN) S PATSSN=$TR($G(SEG(18,1,1,1)),"-")
I $G(PATSSN) S PSJOMS("SSN")=PATSSN
; If unknown patient, find matching patient from SSN or ICN
I '$G(PSJOMS("DFN"))!($G(PSJOMS("DFN"))>0&'$D(^DPT(+$G(PSJOMS("DFN"))))) D
.N PSJDFN,X,Y,PSIX,PSVAL,PSERR,INDEX
.I $G(PATSSN) S PSVAL=PATSSN,INDEX="SSN" S PSJDFN=$$FIND1^DIC(2,,"X",PSVAL,INDEX,,"PSERR"),PSJOMS("DFN")=PSJDFN
.I $G(PSJDFN) S PSJOMS("DFN")=PSJDFN,PSJOMS("PTID")=PATSSN Q
.I $G(PATICN) S PSVAL=PATICN,INDEX="AICN" S PSJDFN=$$FIND1^DIC(2,,"X",PSVAL,INDEX,,"PSERR"),PSJOMS("DFN")=PSJDFN
; Set Patient Name
S PSJOMS("PTNAMA")=$G(SEG(5,1,1,1))
S PSJOMS("PTNAMB")=$G(SEG(5,2,1,1)) S:PSJOMS("PTNAMB")="" PSJOMS("PTNAMB")=$G(SEG(5,1,2,1))
S PSJOMS("PTNAMC")=$G(SEG(5,3,1,1)) S:PSJOMS("PTNAMC")="" PSJOMS("PTNAMC")=$G(SEG(5,1,3,1))
I '$G(PSJOMS("DFN")),(PSJOMS("PTID")?1.N),'$G(PATSSN) D
.N DPTNAME
.Q:'$D(^DPT(+PSJOMS("PTID"),0)) S DPTNAME=$P($G(^DPT(PSJOMS("PTID"),0)),"^")
.Q:DPTNAME="" I $$UPPER^HLFNC($E(PSJOMS("PTNAMA"),1,$L(PSJOMS("PTNAMA"))))=$$UPPER^HLFNC($E(DPTNAME,1,$L(PSJOMS("PTNAMA")))) S PSJOMS("DFN")=PSJOMS("PTID")
;
I $G(PSJOMS("DFN")) N PSJNAM,PSJMINAM S PSJNAM=$P($G(^DPT(+$G(PSJOMS("DFN")),0)),"^") I $L(PSJNAM)>2 D
.S PSJMINAM=$P($P(PSJNAM,",",2)," ",2)
.I $L(PSJMINAM)>0 S PSJOMS("PTNAMC")=PSJMINAM
I '$G(PSJOMS("DFN"))!($G(PSJOMS("DFN"))&'$D(^DPT(+$G(PSJOMS("DFN")),0))) D
.S PSJOMS("MDFN")=$G(PSJOMS("DFN")),PSJOMS("MPTNAMA")=PSJOMS("PTNAMA"),PSJOMS("MPTNAMB")=PSJOMS("PTNAMB")
Q
;
PV1 ; Parse PV1 segment
S PSJOMS("PV1")=$G(SEG(0))
S PSJOMS("PTCLASS")=$G(SEG(2,1,1,1)) ; Patient Class
S PSJOMS("PTLOC")=$G(SEG(3,1,1,1)) ; Patient Location
S PSJOMS("PTROOM")=$G(SEG(3,2,1,1)) ; Room
S PSJOMS("PTBED")=$G(SEG(3,3,1,1)) ; Bed
Q
;
ORC ; Parse ORC segment
S PSJOMS("ORC")=$G(SEG(0))
S PSJOMS("VAORD")=$G(SEG(2,1,1,1)) ; Pharmacy Order
S:'PSJOMS("VAORD") PSJOMS("VAORD")=""
S PSJOMS("XORD")=$G(SEG(3,1,1,1)) ; External order
S PSJOMS("DTRDT")=$G(SEG(9,1,1,1)) ; Transaction Date/Time
Q
;
RQD ; Parse RQD segment
S PSJOMS("RQD")=$G(SEG(0))
S PSJOMS("DRGIID")=$G(SEG(2,1,1,1)) ; Internal Drug ID
S PSJOMS("DRGITXT")=$G(SEG(2,2,1,1)) ; Interla drug text name
S PSJOMS("DRGEID")=$G(SEG(3,1,1,1)) ; External Drug ID
S PSJOMS("DRGETXT")=$G(SEG(3,2,1,1)) ; External drug text name
S PSJOMS("QTY")=$G(SEG(5,1,1,1)) ; Quantity of drug
S PSJOMS("DRGUNIT")=$G(SEG(6,1,1,1)) ; Drug Units
Q
;
ZPM ; Parse ZPM segment
N PSJFSET,PSJUFSET S PSJFSET=0,PSJUFSET=0
S PSJOMS("ZPM")=$G(SEG(0))
S PSJOMS("TTYPE")=$G(SEG(1,1,1,1)) ; Transaction Type
S PSJOMS("STYP")=$G(PSJOMS("TTYPE"))
S PSJOMS("DISPSYS")=$G(SEG(2,1,1,1)) ; PADE Inbound System
S PSJOMS("CABID")=$G(SEG(3,1,1,1)) ; Cabinet/Device ID
S PSJOMS("DRWR")=$G(SEG(4,1,1,1)) ; Drawer
S PSJOMS("PKT")=$G(SEG(5,1,1,1)) ; Pocket
S PSJOMS("DRGITM")=$G(SEG(6,1,1,1)) ; Drug Item
S PSJOMS("DRGIID")=PSJOMS("DRGITM") ; Drug Internal ID
S:PSJOMS("TTYPE")="I" PSJOMS("TTYPE")="V"
S PSJOMS("DRGTXT")=$G(SEG(6,1,2,1)) I PSJOMS("DRGTXT")="" S PSJOMS("DRGTXT")=$G(SEG(6,2,1,1)) ; Drug text name
I $G(HL("VER"))=2.3 D ; Backward compatible parsing - use field separator as component separator for ZPM only
.S PSJOMS("DRGTXT")=$G(SEG(7,1,1,1)),PSJFSET=PSJFSET+1
S PSJOMS("DITMCLS")=$G(SEG(7+PSJFSET,1,1,1)) ; Drug CS Class
S PSJOMS("EXBCNT")=$G(SEG(8+PSJFSET,1,1,1)) ; Expected Begin Count
S PSJOMS("ACBCNT")=$G(SEG(9+PSJFSET,1,1,1)) ; Actual Begin Count
;
; If NULL is sent as a Begin Count, it wasn't really sent. Must be numeric
I PSJOMS("TTYPE")'="A" D
.I PSJOMS("EXBCNT")="",(PSJOMS("ACBCNT")'="") S PSJOMS("EXBCNT")=PSJOMS("ACBCNT")
.I PSJOMS("ACBCNT")="",(PSJOMS("EXBCNT")'="") S PSJOMS("ACBCNT")=PSJOMS("EXBCNT")
.S PSJOMS("ACBCNT")=+PSJOMS("ACBCNT"),PSJOMS("EXBCNT")=+PSJOMS("EXBCNT")
;
; If "V"end transaction, use Expected Begin Count
I PSJOMS("TTYPE")="V" S PSJOMS("ACBCNT")=$G(PSJOMS("EXBCNT"))
;
S PSJOMS("TRNSAMT")=$G(SEG(10+PSJFSET,1,1,1)) ; Transaction Amount
;
; Adjust inventory update transaction information, depending on transaction type
I PSJOMS("TTYPE")="L" D
.I $G(PSJOMS("EXBCNT")) S PSJOMS("TRNSAMT")=+$G(PSJOMS("EXBCNT"))
.I '$G(PSJOMS("EXBCNT")) S PSJOMS("TRNSAMT")=+$G(PSJOMS("ACBCNT"))
.S PSJOMS("EXBCNT")=0,PSJOMS("ACBCNT")=0
;
I PSJOMS("TTYPE")="C" D ; Ignore transaction amount for COUNT transactions
.I $G(PSJOMS("ACBCNT")) S PSJOMS("TRNSAMT")=PSJOMS("ACBCNT")
.I ($G(PSJOMS("ACBCNT"))=""),$G(PSJOMS("TRNSAMT")) S PSJOMS("ACBCNT")=+$G(PSJOMS("TRNSAMT"))
;
I PSJOMS("TTYPE")="U" D
.I '$G(PSJOMS("ACBCNT")) S PSJOMS("TRNSAMT")=PSJOMS("EXBCNT"),PSJOMS("ACBCNT")=PSJOMS("EXBCNT")
.I '$G(PSJOMS("EXBCNT")) S PSJOMS("TRNSAMT")=PSJOMS("ACBCNT"),PSJOMS("EXBCNT")=PSJOMS("ACBCNT")
;
I PSJOMS("TTYPE")="A",PSJOMS("ACBCNT")="" S PSJOMS("ACBCNT")=PSJOMS("EXBCNT")+PSJOMS("TRNSAMT") S:PSJOMS("ACBCNT")<0 PSJOMS("ACBCNT")=0
;
; Parse User information
S PSJOMS("NUR1A")=$G(SEG(11+PSJFSET,1,1,1))
S PSJOMS("NUR1B")=$G(SEG(11+PSJFSET,1,2,1)) I PSJOMS("NUR1B")="" S PSJOMS("NUR1B")=$G(SEG(11+PSJFSET,2,1,1))
S PSJOMS("NUR1C")=$G(SEG(11+PSJFSET,1,3,1)) I PSJOMS("NUR1C")="" S PSJOMS("NUR1C")=$G(SEG(11+PSJFSET,3,1,1))
I $G(HL("VER"))=2.3 D ; Backward compatible parsing - use field separator as component separator for ZPM only
.S PSJFSET=PSJFSET+1,PSJOMS("NUR1B")=$G(SEG(11+PSJFSET,1,1,1))
.I PSJOMS("NUR1B")["," S PSJOMS("NUR1C")=$P(PSJOMS("NUR1B"),",",2),PSJOMS("NUR1B")=$P(PSJOMS("NUR1B"),",")
I PSJOMS("NUR1B")=""&(PSJOMS("NUR1C")="") S PSJOMS("NUR1B")="USER",PSJOMS("NUR1C")="PADE"
I PSJOMS("NUR1B")=""&(PSJOMS("NUR1C")["_") S PSJOMS("NUR1B")=$P(PSJOMS("NUR1C"),"_"),PSJOMS("NUR1C")=$P(PSJOMS("NUR1C"),"_",2)
I PSJOMS("NUR1C")=""&(PSJOMS("NUR1B")["_") S PSJOMS("NUR1C")=$P(PSJOMS("NUR1B"),"_",2),PSJOMS("NUR1B")=$P(PSJOMS("NUR1B"),"_")
; Parse Witness information
S PSJOMS("NUR2A")=$G(SEG(12+PSJFSET,1,1,1))
S PSJOMS("NUR2B")=$G(SEG(12+PSJFSET,1,2,1)) I PSJOMS("NUR2B")="" S PSJOMS("NUR2B")=$G(SEG(12+PSJFSET,2,1,1))
S PSJOMS("NUR2C")=$G(SEG(12+PSJFSET,1,3,1)) I PSJOMS("NUR2C")="" S PSJOMS("NUR2C")=$G(SEG(12+PSJFSET,3,1,1))
I $G(HL("VER"))=2.3 D ; Backward compatible parsing - use field separator as component separator for ZPM only
.S PSJFSET=PSJFSET+1,PSJOMS("NUR2B")=$G(SEG(12+PSJFSET,1,1,1))
.I PSJOMS("NUR2B")["," S PSJOMS("NUR2C")=$P(PSJOMS("NUR2B"),",",2),PSJOMS("NUR2B")=$P(PSJOMS("NUR2B"),",")
I PSJOMS("NUR2B")=""&(PSJOMS("NUR2C")["_") S PSJOMS("NUR2B")=$P(PSJOMS("NUR2C"),"_"),PSJOMS("NUR2C")=$P(PSJOMS("NUR2C"),"_",2)
I PSJOMS("NUR2C")=""&(PSJOMS("NUR2B")["_") S PSJOMS("NUR2C")=$P(PSJOMS("NUR2B"),"_",2),PSJOMS("NUR2B")=$P(PSJOMS("NUR2B"),"_")
;
S PSJOMS("TOTITMS")=$G(SEG(13+PSJFSET,1,1,1)) ; Device Drug balance
S PSJOMS("FACIL")=$G(SEG(14+PSJFSET,1,1,1)) ; Facility
S PSJOMS("PSDQ")=$$ABS^XLFMTH($G(PSJOMS("TRNSAMT"))) ; Absolute value of transaction quantity
S PSJOMS("DWARD")=$G(SEG(15+PSJFSET,1,1,1)) ; Ward
S PSJOMS("SBDRWR")=$G(SEG(16+PSJFSET,1,1,1)) ; Subdrawer
S:PSJOMS("SBDRWR")="" PSJOMS("SBDRWR")="~~"
S PSJOMS("PKTCAP")=$G(SEG(17+PSJFSET,1,1,1)) ; PAR Quantity
S PSJOMS("POREORD")=$G(SEG(18+PSJFSET,1,1,1)) ; Reorder Qty
S PSJOMS("PSJDT")=$P($G(SEG(19+PSJFSET,1,1,1)),"-") ; Transaction Date
S PSJOMS("PSJDT")=$E(PSJOMS("PSJDT"),1,14)
S PSJOMS("LOTNUM")=$G(SEG(20+PSJFSET,1,1,1)) ; Lot Number
S PSJOMS("SERNUM")=$G(SEG(21+PSJFSET,1,1,1)) ; Serial Number
I ($G(PSJOMS("DRGUNIT"))="") S PSJOMS("DRGUNIT")=$G(SEG(34+PSJFSET,1,1,1))
;
S PSJOMS("NUR1")=$$USER(.PSJOMS,1) ; File User into PADE USER (#58.64) file, if it doesn't already exist
S PSJOMS("NUR2")=$$USER(.PSJOMS,2) ; File Witness into PADE USER (#58.64) file, if it doesn't already exist
Q
;
NTE ; Parse NTE segment
S PSJOMS("NTE")=$G(SEG(0))
S PSJOMS("COMMENT")=$G(SEG(3,1,1,1)) ; Comment
S PSJOMS("CMTYPE")=$G(SEG(4,1,1,1))
I (PSJOMS("CMTYPE")["PATIENT SPECIFIC BIN")!(PSJOMS("CMTYPE")["RETURN BIN") D
.S PSJOMS("COMMENT")=$S((PSJOMS("COMMENT")'=""):PSJOMS("CMTYPE")_"//"_PSJOMS("COMMENT"),1:PSJOMS("CMTYPE"))
.I (PSJOMS("CMTYPE")["PATIENT SPECIFIC BIN") D PSB^PSJPDRUT(.PSJOMS)
.I $E(PSJOMS("CMTYPE"),1,10)="RETURN BIN" S PSJOMS("PKT")=PSJOMS("PKT")_"RB"
Q
;
ERROR(TEXT,PSPCFG) ; Log error with PADE inbound HL7 message
Q:$G(TEXT)=""
N GBL,NEXT S GBL="^XTMP(""PSJOMSERR""_+$H)"
S:'$G(@GBL@(0)) @GBL@(0)=$P($$FMADD^XLFDT($$NOW^XLFDT,7),".")_"^"_$P($$NOW^XLFDT,".")_"^"_"PADE HL7 OMS Message Error Log"
S NEXT=+$O(@GBL@(""),-1)+1 S @GBL@(NEXT)=TEXT
D MESSAGE(TEXT,$G(PSPCFG))
Q
;
CHKFLD(FLD,NONZ,LEN,MUMPS,FNAM) ; Validates a minimum Required fields for Not Null
; Input: (r) FLD = field contents from incoming segment
; (o) NONZ = 1 if want to check for field value is Not 0
; (o) LEN = length if want to check specific length of field
; (o) MUMPS= executable True/False code to test specific cond.
; (r) FNAM = HL7 field name, i.e. ZPM.3
;
N ERR S ERR=""
S NONZ=$G(NONZ),LEN=$G(LEN),MUMPS=$G(MUMPS)
S:FLD="" ERR=FNAM_" is null or invalid"
;
;check for more specific validation errors
I NONZ,FLD=0 D
. S ERR=FNAM_" field cannot be 0"
I LEN,$L(FLD)'=LEN D
. S ERR=FNAM_" field is required to be "_LEN_" in length"
I MUMPS]"",@MUMPS D
. S ERR=FNAM_" field is missing or invalid >"_FLD_"<"
Q ERR
;
MESSAGE(ERRTXT,PSPCFG) ;Build message and send to PADE mail group
N MSGTEXT,XMTEXT,XMSUB,XMY,XMZ,XMDUZ,MSGTYPE,MSHREC,PSJPOUT
N HLFS,HLCS,MTXTLN,PSPMGRP,PSPMGCNT,PSPMGTYP,PSPDSYS,PSMSGDT
S MTXTLN=0
S PSMSGDT=$S($G(PSJOMS("PSJDT")):PSJOMS("PSJDT"),1:$$FMTHL7^XLFDT($$NOW^XLFDT))
S MSGTEXT(MTXTLN)=" ",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="An error was encountered while processing a message from PADE",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)=" Date: "_$TR($$FMTE^XLFDT($$HL7TFM^XLFDT(PSMSGDT)),"@"," "),MTXTLN=MTXTLN+1
I $L($G(PSJOMS("PTNAMA")))!$L($G(PSJOMS("PTNAMB"))) D
.N PATNAM S PATNAM=$G(PSJOMS("PTNAMA"))_","_$G(PSJOMS("PTNAMB"))_"^"_$G(PSJOMS("DFN"))
.I $TR(PATNAM," ,^")="" S PATNAM="None"
.S MSGTEXT(MTXTLN)="Patient: "_$G(PATNAM),MTXTLN=MTXTLN+1
I ($G(ERRTXT)'["CABINET=")&$L($G(PSJOMS("CABID"))) S ERRTXT=$G(ERRTXT)_"|CABINET="_PSJOMS("CABID")
I ($G(ERRTXT)'["SYSTEM=")&$L($G(PSJOMS("DISPSYS"))) S ERRTXT=$G(ERRTXT)_"|SYSTEM="_PSJOMS("DISPSYS")
S MSGTEXT(MTXTLN)="Error Msg: "_$G(ERRTXT),MTXTLN=MTXTLN+1
I $E($G(HLHDRO(1,0)),1,3)="MSH" S MSGTEXT(MTXTLN)=" Header: "_HLHDRO(1,0),MTXTLN=MTXTLN+1
; Send message to mail group
S XMSUB=" PADE Error-Msg:"_$G(HLMTIENS)
I ERRTXT["DRUG NOT ON FILE" S XMSUB=XMSUB_"-DRUG NOT ON FILE"
I ERRTXT["PATIENT NOT ON FILE" S XMSUB=XMSUB_"-PATIENT NOT ON FILE"
S XMTEXT="MSGTEXT("
S PSPMGCNT="",PSPDSYS=$$FIND1^DIC(58.601,"","",$G(PSJOMS("DISPSYS")))
I '$G(PSPDSYS) S PSPDSYS=$O(^PS(58.601,0))
S PSPMGTYP=$S($G(PSPCFG):58.6015,1:58.6016)
D LIST^DIC(PSPMGTYP,","_+$G(PSPDSYS)_",",,"P",,,,,,,"PSJPOUT")
S PSPMGCNT=0 F S PSPMGCNT=$O(PSJPOUT("DILIST",PSPMGCNT)) Q:'PSPMGCNT D
.N PSPMGRP
.S PSPMGRP=$P($G(PSJPOUT("DILIST",PSPMGCNT,0)),"^",2)
.S XMY("G."_PSPMGRP)=""
I $D(XMY)<10 D GETPDMGR^PSJPAD7I(.XMY)
Q:$D(XMY)<10
S (XMDUZ)="PADE"
D ^XMD
Q
;
VALSYS(SYS) ; Validate PADE system SYS. Return PADE INVENTORY SYSTEM (#58.601) file IEN if SYS exists an entry.
K PSJIEN
D FIND^DIC(58.601,"","@","",SYS,"","","","","PSJIEN")
Q $G(PSJIEN("DILIST",2,1))
;
VALCAB(SYS,CAB) ; Validate PADE Cabinet CAB for system SYS.
; Return pointer to DISPENSING DEVICE (#1) multiple (sub-file 58.6011) in PADE INVENTORY SYSTEM (#58.601) file.
K PSJIEN
D FIND^DIC(58.6011,","_$$VALSYS(SYS)_",","@","",CAB,"","","","","PSJIEN","MSG")
Q $G(PSJIEN("DILIST",2,1))
;
USER(PSJOMS,TYPE) ; Find VistA User DUZ
K PSJUDUZ
;
N NURNAM,SCR,PSJPSYS,PSJUSRID,PSUBB,PSUBC,PTMPF,PTMPL,PTMP
S PSJPSYS=$$FIND1^DIC(58.601,,"MX",$G(PSJOMS("DISPSYS")))
S PSJUSRID=""
S PSJUSRID=$S($G(TYPE)=1:$G(PSJOMS("NUR1A")),$G(TYPE)=2:$G(PSJOMS("NUR2A")),1:"")
; If the Family Name was sent as FIRST,LAST, set PSJOMS("NUR<TYPE>B") and PSJOMS("NUR<TYPE>C")
I $G(TYPE) S PSUBB="NUR"_$G(TYPE)_"B",PTMP=$G(PSJOMS(PSUBB)) I PTMP]"" D
.N PSUBC S PSUBC="NUR"_$G(TYPE)_"C"
.S PTMPF="",PTMPL=""
.S PTMPF=$G(PSJOMS(PSUBC))
.S PTMPL=$G(PSJOMS(PSUBB))
.I PTMP["," S PTMPL=$P(PTMP,","),PTMPF=$P(PTMP,",",2)
.; If Given name also contains a name, quit
.S PSUBC="NUR"_$G(TYPE)_"C",PTMP=$G(PSJOMS(PSUBC)) I PTMP]"" Q
.S:PTMPL="" PTMPL="PADE"
.S:PTMPF="" PTMPF="USER"
.S PSJOMS(PSUBB)=PTMPL,PSJOMS(PSUBC)=PTMPF
I $G(TYPE)=1 S NURNAM=$TR($G(PSJOMS("NUR1B")),",")_","_$TR($G(PSJOMS("NUR1C")),",")
I $G(TYPE)=2 S NURNAM=$TR($G(PSJOMS("NUR2B")),",")_","_$TR($G(PSJOMS("NUR2C")),",")
; If no primary USER is received, stuff in generic user
I $G(TYPE)=1 I ($P(NURNAM,",")="")&($P(NURNAM,",",2)="") S NURNAM="USER,PADE"
;
S PSJUDUZ=""
S PSJUDUZ=$$FILUSR(PSJPSYS,NURNAM,PSJUSRID)
Q PSJUDUZ
;
FINDIENS(FILES,VALS) ; Find IENS for VALS in file/sub-files within FILE
K PSJIEN N PSJC,MSG,FILE,PSJIENS,VAL
F PSJC=1:1 S FILE=$P(FILES,"^",PSJC),VAL=$P(VALS,"^",PSJC) Q:FILE=""!(VAL="") D
.I PSJC=1 D FIND^DIC(FILE,"","@","",VAL,"","","","","PSJIEN","MSG") S PSJIENS=","_$G(PSJIEN("DILIST",2,1))_"," Q
.D FIND^DIC(FILE,PSJIENS,"@","",VAL,"","","","","PSJIEN","MSG")
.S PSJIENS=$G(PSJIENS)_$G(PSJIEN("DILIST",2,1))_","
Q $P(PSJIENS,",",2,$L(PSJIENS,",")-1)
;
FILUSR(PSJPSYS,PSJNAME,PSJPUSR) ; File PADE user to PADE USER (#58.64) if not already on file
N PSJGETUS,PSJERR,PSJKEY,PSJVAL,PSJDUZ,FDA,ERR,PADUSIEN,PSJDUZ
Q:$G(PSJPUSR)="" ""
S PSJDUZ=""
S PADUSIEN=$O(^PS(58.64,"C",+$G(PSJPSYS),$G(PSJPUSR),""))
; If user ID PSJPUSR has already been filed for PADE system PSJPSYS, return Vista DUZ if one has been added
I $G(PADUSIEN) S PSJDUZ=$P($G(^PS(58.64,PADUSIEN,0)),"^",3) I PSJDUZ Q PSJDUZ
; If user ID PSJPUSR for PADE system PSJPSYS is not on file, add it
K FDA,ERR
I ($G(PSJPUSR)?1N.15N),$D(^VA(200,PSJPUSR,0)) D
.N DBNAMEF,DBNAMEG,HLNAMEF,HLNAMEG,FLEN,GLEN
.S DBNAMEF=$P($G(^VA(200,PSJPUSR,0)),"^")
.S DBNAMEG=$P(DBNAMEF,",",2),DBNAMEF=$P(DBNAMEF,",")
.S HLNAMEF=$P($G(PSJNAME),","),HLNAMEG=$P($G(PSJNAME),",",2)
.S FLEN=$L(HLNAMEF),GLEN=$L(HLNAMEG)
.Q:$$UPPER^HLFNC($E(DBNAMEF,1,2))'=$$UPPER^HLFNC($E(HLNAMEF,1,2))
.S FDA(58.64,"+1,",2)=+PSJPUSR,PSJDUZ=+PSJPUSR
;
S FDA(58.64,"+1,",.01)=PSJNAME
S FDA(58.64,"+1,",1)=PSJPUSR
S FDA(58.64,"+1,",1.1)="`"_PSJPSYS
D UPDATE^DIE("E","FDA","","ERR")
Q $G(PSJDUZ)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPAD7U 16892 printed Sep 23, 2025@19:44:42 Page 2
PSJPAD7U ;BIR/JCH-HL7 RECEIVER OMS PADE POCKET ACTIVITY ;9/3/15 1:34 PM
+1 ;;5.0;INPATIENT MEDICATIONS ;**317**;16 DEC 97;Build 130
+2 ;
+3 ; Reference to ^HLPRS is supported by DBIA #4742
+4 ; Reference to ^XLFDT is supported by DBIA #10103.
+5 ; Reference to ^XLFMTH is supported by DBIA #10105.
+6 ; Reference to ^XMD is supported by DBIA #10070.
+7 ;
+8 ;Direct entry not supported
QUIT
+9 ;
LOADMSG(PSJOMS,PSJMSH,PSJERR) ; Load HL7 message into temporary global for processing
+1 ;This subroutine assumes that all VistA HL7 environment variables are properly initialized
+2 NEW HEADER,OK,SEG,HLHDRO,HLMSG,HLMTIEN,HLMTIENS,HLVER
+3 SET PSJERR=""
+4 SET OK=$$STARTMSG^HLPRS(.HLMSG,+PSJMSH,.HEADER)
IF 'OK
Begin DoDot:1
+5 SET PSJERR="MSH - No header message defined"
+6 DO ERROR^PSJPAD7U(PSJERR,1)
QUIT
End DoDot:1
QUIT
+7 ;
+8 ;begin parsing of segments and validate
+9 DO MSH
+10 FOR
if '$$NEXTSEG^HLPRS(.HLMSG,.SEG)
QUIT
DO DECODE
+11 QUIT
+12 ;
DECODE ; parse out data from segments
+1 KILL FIELD
SET FIELD(0)=""
+2 SET FIELD(0)=$GET(SEG("SEGMENT TYPE"))
+3 IF (",MSH,ORC,PID,PV1,RQD,ZPM,NTE,")[(","_FIELD(0)_",")
DO @FIELD(0)
+4 QUIT
+5 ;
MSH ; Get Message Identifiers
+1 SET PSJOMS("HLMTIEN")=$GET(HLMTIEN)
+2 SET PSJOMS("HLMTIENS")=$GET(HLMTIENS)
+3 SET PSJOMS("HLVER")=$GET(HL("VER"))
+4 QUIT
+5 ;
PID ; Parse PID segment
+1 NEW II,PATICN,PATSSN,PATDFN,PATID,QQ
+2 SET PSJOMS("PID")=$GET(SEG(0))
+3 SET PSJOMS("PTID")=$GET(SEG(3,1,1,1))
+4 ;
+5 FOR QQ=1:1:4
SET PATID=$GET(SEG(3,QQ,3,1))
Begin DoDot:1
+6 if PATID="NI"
SET PATICN=$GET(SEG(3,QQ,1,1))
+7 IF PATID="SS"
SET PATSSN=$GET(SEG(3,QQ,1,1))
+8 if PATID="PI"!(PATID="M10")
SET PATDFN=$GET(SEG(3,QQ,1,1))
End DoDot:1
+9 IF PATID=""
FOR QQ=1:1:4
SET PATID=$GET(SEG(3,3,QQ,1))
Begin DoDot:1
+10 if PATID="NI"
SET PATICN=$GET(SEG(3,1,QQ,1))
+11 IF PATID="SS"
SET PATSSN=$GET(SEG(3,1,QQ,1))
+12 if PATID="PI"!(PATID="M10")
SET PATDFN=$GET(SEG(3,1,QQ,1))
End DoDot:1
+13 ; If it's not in PATIENT (#2) file, it's not a valid DFN
+14 IF $GET(PATDFN)
IF '$DATA(^DPT(PATDFN,0))
SET PATDFN=0
+15 if $GET(PATDFN)
SET PSJOMS("DFN")=PATDFN
+16 ; Get patient SSN from PID.19 Patient SSN
+17 IF '$GET(PATSSN)
SET PATSSN=$TRANSLATE($GET(SEG(19,1,1,1)),"-")
+18 ; If no SSN in PID.19, check PID.18
+19 IF '$GET(PATSSN)
SET PATSSN=$TRANSLATE($GET(SEG(18,1,1,1)),"-")
+20 IF $GET(PATSSN)
SET PSJOMS("SSN")=PATSSN
+21 ; If unknown patient, find matching patient from SSN or ICN
+22 IF '$GET(PSJOMS("DFN"))!($GET(PSJOMS("DFN"))>0&'$DATA(^DPT(+$GET(PSJOMS("DFN")))))
Begin DoDot:1
+23 NEW PSJDFN,X,Y,PSIX,PSVAL,PSERR,INDEX
+24 IF $GET(PATSSN)
SET PSVAL=PATSSN
SET INDEX="SSN"
SET PSJDFN=$$FIND1^DIC(2,,"X",PSVAL,INDEX,,"PSERR")
SET PSJOMS("DFN")=PSJDFN
+25 IF $GET(PSJDFN)
SET PSJOMS("DFN")=PSJDFN
SET PSJOMS("PTID")=PATSSN
QUIT
+26 IF $GET(PATICN)
SET PSVAL=PATICN
SET INDEX="AICN"
SET PSJDFN=$$FIND1^DIC(2,,"X",PSVAL,INDEX,,"PSERR")
SET PSJOMS("DFN")=PSJDFN
End DoDot:1
+27 ; Set Patient Name
+28 SET PSJOMS("PTNAMA")=$GET(SEG(5,1,1,1))
+29 SET PSJOMS("PTNAMB")=$GET(SEG(5,2,1,1))
if PSJOMS("PTNAMB")=""
SET PSJOMS("PTNAMB")=$GET(SEG(5,1,2,1))
+30 SET PSJOMS("PTNAMC")=$GET(SEG(5,3,1,1))
if PSJOMS("PTNAMC")=""
SET PSJOMS("PTNAMC")=$GET(SEG(5,1,3,1))
+31 IF '$GET(PSJOMS("DFN"))
IF (PSJOMS("PTID")?1.N)
IF '$GET(PATSSN)
Begin DoDot:1
+32 NEW DPTNAME
+33 if '$DATA(^DPT(+PSJOMS("PTID"),0))
QUIT
SET DPTNAME=$PIECE($GET(^DPT(PSJOMS("PTID"),0)),"^")
+34 if DPTNAME=""
QUIT
IF $$UPPER^HLFNC($EXTRACT(PSJOMS("PTNAMA"),1,$LENGTH(PSJOMS("PTNAMA"))))=$$UPPER^HLFNC($EXTRACT(DPTNAME,1,$LENGTH(PSJOMS("PTNAMA"))))
SET PSJOMS("DFN")=PSJOMS("PTID")
End DoDot:1
+35 ;
+36 IF $GET(PSJOMS("DFN"))
NEW PSJNAM,PSJMINAM
SET PSJNAM=$PIECE($GET(^DPT(+$GET(PSJOMS("DFN")),0)),"^")
IF $LENGTH(PSJNAM)>2
Begin DoDot:1
+37 SET PSJMINAM=$PIECE($PIECE(PSJNAM,",",2)," ",2)
+38 IF $LENGTH(PSJMINAM)>0
SET PSJOMS("PTNAMC")=PSJMINAM
End DoDot:1
+39 IF '$GET(PSJOMS("DFN"))!($GET(PSJOMS("DFN"))&'$DATA(^DPT(+$GET(PSJOMS("DFN")),0)))
Begin DoDot:1
+40 SET PSJOMS("MDFN")=$GET(PSJOMS("DFN"))
SET PSJOMS("MPTNAMA")=PSJOMS("PTNAMA")
SET PSJOMS("MPTNAMB")=PSJOMS("PTNAMB")
End DoDot:1
+41 QUIT
+42 ;
PV1 ; Parse PV1 segment
+1 SET PSJOMS("PV1")=$GET(SEG(0))
+2 ; Patient Class
SET PSJOMS("PTCLASS")=$GET(SEG(2,1,1,1))
+3 ; Patient Location
SET PSJOMS("PTLOC")=$GET(SEG(3,1,1,1))
+4 ; Room
SET PSJOMS("PTROOM")=$GET(SEG(3,2,1,1))
+5 ; Bed
SET PSJOMS("PTBED")=$GET(SEG(3,3,1,1))
+6 QUIT
+7 ;
ORC ; Parse ORC segment
+1 SET PSJOMS("ORC")=$GET(SEG(0))
+2 ; Pharmacy Order
SET PSJOMS("VAORD")=$GET(SEG(2,1,1,1))
+3 if 'PSJOMS("VAORD")
SET PSJOMS("VAORD")=""
+4 ; External order
SET PSJOMS("XORD")=$GET(SEG(3,1,1,1))
+5 ; Transaction Date/Time
SET PSJOMS("DTRDT")=$GET(SEG(9,1,1,1))
+6 QUIT
+7 ;
RQD ; Parse RQD segment
+1 SET PSJOMS("RQD")=$GET(SEG(0))
+2 ; Internal Drug ID
SET PSJOMS("DRGIID")=$GET(SEG(2,1,1,1))
+3 ; Interla drug text name
SET PSJOMS("DRGITXT")=$GET(SEG(2,2,1,1))
+4 ; External Drug ID
SET PSJOMS("DRGEID")=$GET(SEG(3,1,1,1))
+5 ; External drug text name
SET PSJOMS("DRGETXT")=$GET(SEG(3,2,1,1))
+6 ; Quantity of drug
SET PSJOMS("QTY")=$GET(SEG(5,1,1,1))
+7 ; Drug Units
SET PSJOMS("DRGUNIT")=$GET(SEG(6,1,1,1))
+8 QUIT
+9 ;
ZPM ; Parse ZPM segment
+1 NEW PSJFSET,PSJUFSET
SET PSJFSET=0
SET PSJUFSET=0
+2 SET PSJOMS("ZPM")=$GET(SEG(0))
+3 ; Transaction Type
SET PSJOMS("TTYPE")=$GET(SEG(1,1,1,1))
+4 SET PSJOMS("STYP")=$GET(PSJOMS("TTYPE"))
+5 ; PADE Inbound System
SET PSJOMS("DISPSYS")=$GET(SEG(2,1,1,1))
+6 ; Cabinet/Device ID
SET PSJOMS("CABID")=$GET(SEG(3,1,1,1))
+7 ; Drawer
SET PSJOMS("DRWR")=$GET(SEG(4,1,1,1))
+8 ; Pocket
SET PSJOMS("PKT")=$GET(SEG(5,1,1,1))
+9 ; Drug Item
SET PSJOMS("DRGITM")=$GET(SEG(6,1,1,1))
+10 ; Drug Internal ID
SET PSJOMS("DRGIID")=PSJOMS("DRGITM")
+11 if PSJOMS("TTYPE")="I"
SET PSJOMS("TTYPE")="V"
+12 ; Drug text name
SET PSJOMS("DRGTXT")=$GET(SEG(6,1,2,1))
IF PSJOMS("DRGTXT")=""
SET PSJOMS("DRGTXT")=$GET(SEG(6,2,1,1))
+13 ; Backward compatible parsing - use field separator as component separator for ZPM only
IF $GET(HL("VER"))=2.3
Begin DoDot:1
+14 SET PSJOMS("DRGTXT")=$GET(SEG(7,1,1,1))
SET PSJFSET=PSJFSET+1
End DoDot:1
+15 ; Drug CS Class
SET PSJOMS("DITMCLS")=$GET(SEG(7+PSJFSET,1,1,1))
+16 ; Expected Begin Count
SET PSJOMS("EXBCNT")=$GET(SEG(8+PSJFSET,1,1,1))
+17 ; Actual Begin Count
SET PSJOMS("ACBCNT")=$GET(SEG(9+PSJFSET,1,1,1))
+18 ;
+19 ; If NULL is sent as a Begin Count, it wasn't really sent. Must be numeric
+20 IF PSJOMS("TTYPE")'="A"
Begin DoDot:1
+21 IF PSJOMS("EXBCNT")=""
IF (PSJOMS("ACBCNT")'="")
SET PSJOMS("EXBCNT")=PSJOMS("ACBCNT")
+22 IF PSJOMS("ACBCNT")=""
IF (PSJOMS("EXBCNT")'="")
SET PSJOMS("ACBCNT")=PSJOMS("EXBCNT")
+23 SET PSJOMS("ACBCNT")=+PSJOMS("ACBCNT")
SET PSJOMS("EXBCNT")=+PSJOMS("EXBCNT")
End DoDot:1
+24 ;
+25 ; If "V"end transaction, use Expected Begin Count
+26 IF PSJOMS("TTYPE")="V"
SET PSJOMS("ACBCNT")=$GET(PSJOMS("EXBCNT"))
+27 ;
+28 ; Transaction Amount
SET PSJOMS("TRNSAMT")=$GET(SEG(10+PSJFSET,1,1,1))
+29 ;
+30 ; Adjust inventory update transaction information, depending on transaction type
+31 IF PSJOMS("TTYPE")="L"
Begin DoDot:1
+32 IF $GET(PSJOMS("EXBCNT"))
SET PSJOMS("TRNSAMT")=+$GET(PSJOMS("EXBCNT"))
+33 IF '$GET(PSJOMS("EXBCNT"))
SET PSJOMS("TRNSAMT")=+$GET(PSJOMS("ACBCNT"))
+34 SET PSJOMS("EXBCNT")=0
SET PSJOMS("ACBCNT")=0
End DoDot:1
+35 ;
+36 ; Ignore transaction amount for COUNT transactions
IF PSJOMS("TTYPE")="C"
Begin DoDot:1
+37 IF $GET(PSJOMS("ACBCNT"))
SET PSJOMS("TRNSAMT")=PSJOMS("ACBCNT")
+38 IF ($GET(PSJOMS("ACBCNT"))="")
IF $GET(PSJOMS("TRNSAMT"))
SET PSJOMS("ACBCNT")=+$GET(PSJOMS("TRNSAMT"))
End DoDot:1
+39 ;
+40 IF PSJOMS("TTYPE")="U"
Begin DoDot:1
+41 IF '$GET(PSJOMS("ACBCNT"))
SET PSJOMS("TRNSAMT")=PSJOMS("EXBCNT")
SET PSJOMS("ACBCNT")=PSJOMS("EXBCNT")
+42 IF '$GET(PSJOMS("EXBCNT"))
SET PSJOMS("TRNSAMT")=PSJOMS("ACBCNT")
SET PSJOMS("EXBCNT")=PSJOMS("ACBCNT")
End DoDot:1
+43 ;
+44 IF PSJOMS("TTYPE")="A"
IF PSJOMS("ACBCNT")=""
SET PSJOMS("ACBCNT")=PSJOMS("EXBCNT")+PSJOMS("TRNSAMT")
if PSJOMS("ACBCNT")<0
SET PSJOMS("ACBCNT")=0
+45 ;
+46 ; Parse User information
+47 SET PSJOMS("NUR1A")=$GET(SEG(11+PSJFSET,1,1,1))
+48 SET PSJOMS("NUR1B")=$GET(SEG(11+PSJFSET,1,2,1))
IF PSJOMS("NUR1B")=""
SET PSJOMS("NUR1B")=$GET(SEG(11+PSJFSET,2,1,1))
+49 SET PSJOMS("NUR1C")=$GET(SEG(11+PSJFSET,1,3,1))
IF PSJOMS("NUR1C")=""
SET PSJOMS("NUR1C")=$GET(SEG(11+PSJFSET,3,1,1))
+50 ; Backward compatible parsing - use field separator as component separator for ZPM only
IF $GET(HL("VER"))=2.3
Begin DoDot:1
+51 SET PSJFSET=PSJFSET+1
SET PSJOMS("NUR1B")=$GET(SEG(11+PSJFSET,1,1,1))
+52 IF PSJOMS("NUR1B")[","
SET PSJOMS("NUR1C")=$PIECE(PSJOMS("NUR1B"),",",2)
SET PSJOMS("NUR1B")=$PIECE(PSJOMS("NUR1B"),",")
End DoDot:1
+53 IF PSJOMS("NUR1B")=""&(PSJOMS("NUR1C")="")
SET PSJOMS("NUR1B")="USER"
SET PSJOMS("NUR1C")="PADE"
+54 IF PSJOMS("NUR1B")=""&(PSJOMS("NUR1C")["_")
SET PSJOMS("NUR1B")=$PIECE(PSJOMS("NUR1C"),"_")
SET PSJOMS("NUR1C")=$PIECE(PSJOMS("NUR1C"),"_",2)
+55 IF PSJOMS("NUR1C")=""&(PSJOMS("NUR1B")["_")
SET PSJOMS("NUR1C")=$PIECE(PSJOMS("NUR1B"),"_",2)
SET PSJOMS("NUR1B")=$PIECE(PSJOMS("NUR1B"),"_")
+56 ; Parse Witness information
+57 SET PSJOMS("NUR2A")=$GET(SEG(12+PSJFSET,1,1,1))
+58 SET PSJOMS("NUR2B")=$GET(SEG(12+PSJFSET,1,2,1))
IF PSJOMS("NUR2B")=""
SET PSJOMS("NUR2B")=$GET(SEG(12+PSJFSET,2,1,1))
+59 SET PSJOMS("NUR2C")=$GET(SEG(12+PSJFSET,1,3,1))
IF PSJOMS("NUR2C")=""
SET PSJOMS("NUR2C")=$GET(SEG(12+PSJFSET,3,1,1))
+60 ; Backward compatible parsing - use field separator as component separator for ZPM only
IF $GET(HL("VER"))=2.3
Begin DoDot:1
+61 SET PSJFSET=PSJFSET+1
SET PSJOMS("NUR2B")=$GET(SEG(12+PSJFSET,1,1,1))
+62 IF PSJOMS("NUR2B")[","
SET PSJOMS("NUR2C")=$PIECE(PSJOMS("NUR2B"),",",2)
SET PSJOMS("NUR2B")=$PIECE(PSJOMS("NUR2B"),",")
End DoDot:1
+63 IF PSJOMS("NUR2B")=""&(PSJOMS("NUR2C")["_")
SET PSJOMS("NUR2B")=$PIECE(PSJOMS("NUR2C"),"_")
SET PSJOMS("NUR2C")=$PIECE(PSJOMS("NUR2C"),"_",2)
+64 IF PSJOMS("NUR2C")=""&(PSJOMS("NUR2B")["_")
SET PSJOMS("NUR2C")=$PIECE(PSJOMS("NUR2B"),"_",2)
SET PSJOMS("NUR2B")=$PIECE(PSJOMS("NUR2B"),"_")
+65 ;
+66 ; Device Drug balance
SET PSJOMS("TOTITMS")=$GET(SEG(13+PSJFSET,1,1,1))
+67 ; Facility
SET PSJOMS("FACIL")=$GET(SEG(14+PSJFSET,1,1,1))
+68 ; Absolute value of transaction quantity
SET PSJOMS("PSDQ")=$$ABS^XLFMTH($GET(PSJOMS("TRNSAMT")))
+69 ; Ward
SET PSJOMS("DWARD")=$GET(SEG(15+PSJFSET,1,1,1))
+70 ; Subdrawer
SET PSJOMS("SBDRWR")=$GET(SEG(16+PSJFSET,1,1,1))
+71 if PSJOMS("SBDRWR")=""
SET PSJOMS("SBDRWR")="~~"
+72 ; PAR Quantity
SET PSJOMS("PKTCAP")=$GET(SEG(17+PSJFSET,1,1,1))
+73 ; Reorder Qty
SET PSJOMS("POREORD")=$GET(SEG(18+PSJFSET,1,1,1))
+74 ; Transaction Date
SET PSJOMS("PSJDT")=$PIECE($GET(SEG(19+PSJFSET,1,1,1)),"-")
+75 SET PSJOMS("PSJDT")=$EXTRACT(PSJOMS("PSJDT"),1,14)
+76 ; Lot Number
SET PSJOMS("LOTNUM")=$GET(SEG(20+PSJFSET,1,1,1))
+77 ; Serial Number
SET PSJOMS("SERNUM")=$GET(SEG(21+PSJFSET,1,1,1))
+78 IF ($GET(PSJOMS("DRGUNIT"))="")
SET PSJOMS("DRGUNIT")=$GET(SEG(34+PSJFSET,1,1,1))
+79 ;
+80 ; File User into PADE USER (#58.64) file, if it doesn't already exist
SET PSJOMS("NUR1")=$$USER(.PSJOMS,1)
+81 ; File Witness into PADE USER (#58.64) file, if it doesn't already exist
SET PSJOMS("NUR2")=$$USER(.PSJOMS,2)
+82 QUIT
+83 ;
NTE ; Parse NTE segment
+1 SET PSJOMS("NTE")=$GET(SEG(0))
+2 ; Comment
SET PSJOMS("COMMENT")=$GET(SEG(3,1,1,1))
+3 SET PSJOMS("CMTYPE")=$GET(SEG(4,1,1,1))
+4 IF (PSJOMS("CMTYPE")["PATIENT SPECIFIC BIN")!(PSJOMS("CMTYPE")["RETURN BIN")
Begin DoDot:1
+5 SET PSJOMS("COMMENT")=$SELECT((PSJOMS("COMMENT")'=""):PSJOMS("CMTYPE")_"//"_PSJOMS("COMMENT"),1:PSJOMS("CMTYPE"))
+6 IF (PSJOMS("CMTYPE")["PATIENT SPECIFIC BIN")
DO PSB^PSJPDRUT(.PSJOMS)
+7 IF $EXTRACT(PSJOMS("CMTYPE"),1,10)="RETURN BIN"
SET PSJOMS("PKT")=PSJOMS("PKT")_"RB"
End DoDot:1
+8 QUIT
+9 ;
ERROR(TEXT,PSPCFG) ; Log error with PADE inbound HL7 message
+1 if $GET(TEXT)=""
QUIT
+2 NEW GBL,NEXT
SET GBL="^XTMP(""PSJOMSERR""_+$H)"
+3 if '$GET(@GBL@(0))
SET @GBL@(0)=$PIECE($$FMADD^XLFDT($$NOW^XLFDT,7),".")_"^"_$PIECE($$NOW^XLFDT,".")_"^"_"PADE HL7 OMS Message Error Log"
+4 SET NEXT=+$ORDER(@GBL@(""),-1)+1
SET @GBL@(NEXT)=TEXT
+5 DO MESSAGE(TEXT,$GET(PSPCFG))
+6 QUIT
+7 ;
CHKFLD(FLD,NONZ,LEN,MUMPS,FNAM) ; Validates a minimum Required fields for Not Null
+1 ; Input: (r) FLD = field contents from incoming segment
+2 ; (o) NONZ = 1 if want to check for field value is Not 0
+3 ; (o) LEN = length if want to check specific length of field
+4 ; (o) MUMPS= executable True/False code to test specific cond.
+5 ; (r) FNAM = HL7 field name, i.e. ZPM.3
+6 ;
+7 NEW ERR
SET ERR=""
+8 SET NONZ=$GET(NONZ)
SET LEN=$GET(LEN)
SET MUMPS=$GET(MUMPS)
+9 if FLD=""
SET ERR=FNAM_" is null or invalid"
+10 ;
+11 ;check for more specific validation errors
+12 IF NONZ
IF FLD=0
Begin DoDot:1
+13 SET ERR=FNAM_" field cannot be 0"
End DoDot:1
+14 IF LEN
IF $LENGTH(FLD)'=LEN
Begin DoDot:1
+15 SET ERR=FNAM_" field is required to be "_LEN_" in length"
End DoDot:1
+16 IF MUMPS]""
IF @MUMPS
Begin DoDot:1
+17 SET ERR=FNAM_" field is missing or invalid >"_FLD_"<"
End DoDot:1
+18 QUIT ERR
+19 ;
MESSAGE(ERRTXT,PSPCFG) ;Build message and send to PADE mail group
+1 NEW MSGTEXT,XMTEXT,XMSUB,XMY,XMZ,XMDUZ,MSGTYPE,MSHREC,PSJPOUT
+2 NEW HLFS,HLCS,MTXTLN,PSPMGRP,PSPMGCNT,PSPMGTYP,PSPDSYS,PSMSGDT
+3 SET MTXTLN=0
+4 SET PSMSGDT=$SELECT($GET(PSJOMS("PSJDT")):PSJOMS("PSJDT"),1:$$FMTHL7^XLFDT($$NOW^XLFDT))
+5 SET MSGTEXT(MTXTLN)=" "
SET MTXTLN=MTXTLN+1
+6 SET MSGTEXT(MTXTLN)="An error was encountered while processing a message from PADE"
SET MTXTLN=MTXTLN+1
+7 SET MSGTEXT(MTXTLN)=""
SET MTXTLN=MTXTLN+1
+8 SET MSGTEXT(MTXTLN)=" Date: "_$TRANSLATE($$FMTE^XLFDT($$HL7TFM^XLFDT(PSMSGDT)),"@"," ")
SET MTXTLN=MTXTLN+1
+9 IF $LENGTH($GET(PSJOMS("PTNAMA")))!$LENGTH($GET(PSJOMS("PTNAMB")))
Begin DoDot:1
+10 NEW PATNAM
SET PATNAM=$GET(PSJOMS("PTNAMA"))_","_$GET(PSJOMS("PTNAMB"))_"^"_$GET(PSJOMS("DFN"))
+11 IF $TRANSLATE(PATNAM," ,^")=""
SET PATNAM="None"
+12 SET MSGTEXT(MTXTLN)="Patient: "_$GET(PATNAM)
SET MTXTLN=MTXTLN+1
End DoDot:1
+13 IF ($GET(ERRTXT)'["CABINET=")&$LENGTH($GET(PSJOMS("CABID")))
SET ERRTXT=$GET(ERRTXT)_"|CABINET="_PSJOMS("CABID")
+14 IF ($GET(ERRTXT)'["SYSTEM=")&$LENGTH($GET(PSJOMS("DISPSYS")))
SET ERRTXT=$GET(ERRTXT)_"|SYSTEM="_PSJOMS("DISPSYS")
+15 SET MSGTEXT(MTXTLN)="Error Msg: "_$GET(ERRTXT)
SET MTXTLN=MTXTLN+1
+16 IF $EXTRACT($GET(HLHDRO(1,0)),1,3)="MSH"
SET MSGTEXT(MTXTLN)=" Header: "_HLHDRO(1,0)
SET MTXTLN=MTXTLN+1
+17 ; Send message to mail group
+18 SET XMSUB=" PADE Error-Msg:"_$GET(HLMTIENS)
+19 IF ERRTXT["DRUG NOT ON FILE"
SET XMSUB=XMSUB_"-DRUG NOT ON FILE"
+20 IF ERRTXT["PATIENT NOT ON FILE"
SET XMSUB=XMSUB_"-PATIENT NOT ON FILE"
+21 SET XMTEXT="MSGTEXT("
+22 SET PSPMGCNT=""
SET PSPDSYS=$$FIND1^DIC(58.601,"","",$GET(PSJOMS("DISPSYS")))
+23 IF '$GET(PSPDSYS)
SET PSPDSYS=$ORDER(^PS(58.601,0))
+24 SET PSPMGTYP=$SELECT($GET(PSPCFG):58.6015,1:58.6016)
+25 DO LIST^DIC(PSPMGTYP,","_+$GET(PSPDSYS)_",",,"P",,,,,,,"PSJPOUT")
+26 SET PSPMGCNT=0
FOR
SET PSPMGCNT=$ORDER(PSJPOUT("DILIST",PSPMGCNT))
if 'PSPMGCNT
QUIT
Begin DoDot:1
+27 NEW PSPMGRP
+28 SET PSPMGRP=$PIECE($GET(PSJPOUT("DILIST",PSPMGCNT,0)),"^",2)
+29 SET XMY("G."_PSPMGRP)=""
End DoDot:1
+30 IF $DATA(XMY)<10
DO GETPDMGR^PSJPAD7I(.XMY)
+31 if $DATA(XMY)<10
QUIT
+32 SET (XMDUZ)="PADE"
+33 DO ^XMD
+34 QUIT
+35 ;
VALSYS(SYS) ; Validate PADE system SYS. Return PADE INVENTORY SYSTEM (#58.601) file IEN if SYS exists an entry.
+1 KILL PSJIEN
+2 DO FIND^DIC(58.601,"","@","",SYS,"","","","","PSJIEN")
+3 QUIT $GET(PSJIEN("DILIST",2,1))
+4 ;
VALCAB(SYS,CAB) ; Validate PADE Cabinet CAB for system SYS.
+1 ; Return pointer to DISPENSING DEVICE (#1) multiple (sub-file 58.6011) in PADE INVENTORY SYSTEM (#58.601) file.
+2 KILL PSJIEN
+3 DO FIND^DIC(58.6011,","_$$VALSYS(SYS)_",","@","",CAB,"","","","","PSJIEN","MSG")
+4 QUIT $GET(PSJIEN("DILIST",2,1))
+5 ;
USER(PSJOMS,TYPE) ; Find VistA User DUZ
+1 KILL PSJUDUZ
+2 ;
+3 NEW NURNAM,SCR,PSJPSYS,PSJUSRID,PSUBB,PSUBC,PTMPF,PTMPL,PTMP
+4 SET PSJPSYS=$$FIND1^DIC(58.601,,"MX",$GET(PSJOMS("DISPSYS")))
+5 SET PSJUSRID=""
+6 SET PSJUSRID=$SELECT($GET(TYPE)=1:$GET(PSJOMS("NUR1A")),$GET(TYPE)=2:$GET(PSJOMS("NUR2A")),1:"")
+7 ; If the Family Name was sent as FIRST,LAST, set PSJOMS("NUR<TYPE>B") and PSJOMS("NUR<TYPE>C")
+8 IF $GET(TYPE)
SET PSUBB="NUR"_$GET(TYPE)_"B"
SET PTMP=$GET(PSJOMS(PSUBB))
IF PTMP]""
Begin DoDot:1
+9 NEW PSUBC
SET PSUBC="NUR"_$GET(TYPE)_"C"
+10 SET PTMPF=""
SET PTMPL=""
+11 SET PTMPF=$GET(PSJOMS(PSUBC))
+12 SET PTMPL=$GET(PSJOMS(PSUBB))
+13 IF PTMP[","
SET PTMPL=$PIECE(PTMP,",")
SET PTMPF=$PIECE(PTMP,",",2)
+14 ; If Given name also contains a name, quit
+15 SET PSUBC="NUR"_$GET(TYPE)_"C"
SET PTMP=$GET(PSJOMS(PSUBC))
IF PTMP]""
QUIT
+16 if PTMPL=""
SET PTMPL="PADE"
+17 if PTMPF=""
SET PTMPF="USER"
+18 SET PSJOMS(PSUBB)=PTMPL
SET PSJOMS(PSUBC)=PTMPF
End DoDot:1
+19 IF $GET(TYPE)=1
SET NURNAM=$TRANSLATE($GET(PSJOMS("NUR1B")),",")_","_$TRANSLATE($GET(PSJOMS("NUR1C")),",")
+20 IF $GET(TYPE)=2
SET NURNAM=$TRANSLATE($GET(PSJOMS("NUR2B")),",")_","_$TRANSLATE($GET(PSJOMS("NUR2C")),",")
+21 ; If no primary USER is received, stuff in generic user
+22 IF $GET(TYPE)=1
IF ($PIECE(NURNAM,",")="")&($PIECE(NURNAM,",",2)="")
SET NURNAM="USER,PADE"
+23 ;
+24 SET PSJUDUZ=""
+25 SET PSJUDUZ=$$FILUSR(PSJPSYS,NURNAM,PSJUSRID)
+26 QUIT PSJUDUZ
+27 ;
FINDIENS(FILES,VALS) ; Find IENS for VALS in file/sub-files within FILE
+1 KILL PSJIEN
NEW PSJC,MSG,FILE,PSJIENS,VAL
+2 FOR PSJC=1:1
SET FILE=$PIECE(FILES,"^",PSJC)
SET VAL=$PIECE(VALS,"^",PSJC)
if FILE=""!(VAL="")
QUIT
Begin DoDot:1
+3 IF PSJC=1
DO FIND^DIC(FILE,"","@","",VAL,"","","","","PSJIEN","MSG")
SET PSJIENS=","_$GET(PSJIEN("DILIST",2,1))_","
QUIT
+4 DO FIND^DIC(FILE,PSJIENS,"@","",VAL,"","","","","PSJIEN","MSG")
+5 SET PSJIENS=$GET(PSJIENS)_$GET(PSJIEN("DILIST",2,1))_","
End DoDot:1
+6 QUIT $PIECE(PSJIENS,",",2,$LENGTH(PSJIENS,",")-1)
+7 ;
FILUSR(PSJPSYS,PSJNAME,PSJPUSR) ; File PADE user to PADE USER (#58.64) if not already on file
+1 NEW PSJGETUS,PSJERR,PSJKEY,PSJVAL,PSJDUZ,FDA,ERR,PADUSIEN,PSJDUZ
+2 if $GET(PSJPUSR)=""
QUIT ""
+3 SET PSJDUZ=""
+4 SET PADUSIEN=$ORDER(^PS(58.64,"C",+$GET(PSJPSYS),$GET(PSJPUSR),""))
+5 ; If user ID PSJPUSR has already been filed for PADE system PSJPSYS, return Vista DUZ if one has been added
+6 IF $GET(PADUSIEN)
SET PSJDUZ=$PIECE($GET(^PS(58.64,PADUSIEN,0)),"^",3)
IF PSJDUZ
QUIT PSJDUZ
+7 ; If user ID PSJPUSR for PADE system PSJPSYS is not on file, add it
+8 KILL FDA,ERR
+9 IF ($GET(PSJPUSR)?1N.15N)
IF $DATA(^VA(200,PSJPUSR,0))
Begin DoDot:1
+10 NEW DBNAMEF,DBNAMEG,HLNAMEF,HLNAMEG,FLEN,GLEN
+11 SET DBNAMEF=$PIECE($GET(^VA(200,PSJPUSR,0)),"^")
+12 SET DBNAMEG=$PIECE(DBNAMEF,",",2)
SET DBNAMEF=$PIECE(DBNAMEF,",")
+13 SET HLNAMEF=$PIECE($GET(PSJNAME),",")
SET HLNAMEG=$PIECE($GET(PSJNAME),",",2)
+14 SET FLEN=$LENGTH(HLNAMEF)
SET GLEN=$LENGTH(HLNAMEG)
+15 if $$UPPER^HLFNC($EXTRACT(DBNAMEF,1,2))'=$$UPPER^HLFNC($EXTRACT(HLNAMEF,1,2))
QUIT
+16 SET FDA(58.64,"+1,",2)=+PSJPUSR
SET PSJDUZ=+PSJPUSR
End DoDot:1
+17 ;
+18 SET FDA(58.64,"+1,",.01)=PSJNAME
+19 SET FDA(58.64,"+1,",1)=PSJPUSR
+20 SET FDA(58.64,"+1,",1.1)="`"_PSJPSYS
+21 DO UPDATE^DIE("E","FDA","","ERR")
+22 QUIT $GET(PSJDUZ)
