PSJPAD70 ;BIR/JCH - HL7 UTILITY FOR PADE INBOUND POCKET ACTIVITY ;01/06/16 1:34 PM
;;5.0;INPATIENT MEDICATIONS;**317,356,376**;16 DEC 97;Build 4
;
; Reference to $$HLDATE^HLFNC is supported by DBIA 10106
; Reference to ^XMD is supported by DBIA 10070
; Reference to ^XLFDT is supported by DBIA# 10103.
;
Q
;
DWO(PSJOMS) ; Send Dispensed Without Order (DWO) Alert
N GROUPS
S GROUPS=""
Q:'$$ACTDWO(.PSJOMS)
D GETGRPS(.PSJOMS,.GROUPS)
D DWOSEND(.PSJOMS,.GROUPS)
Q
;
ACTDWO(PSJOMS) ; Check if dispensing device (cabinet) is active for DWO messages
N CABNAME,CABIEN,RESULT,ERROR,PSJPSYS
; Get PADE Inbound System name
S PSJPSYS=$G(PSJOMS("DISPSYS")) Q:(PSJPSYS="") 0
S PSJPSYS=$$FIND1^DIC(58.601,"","",PSJPSYS) K DIERR Q:'PSJPSYS "" ;*356
; Get Cabinet name
S CABNAME=$G(PSJOMS("CABID")) Q:(CABNAME="") 0
K DIERR S CABIEN=$$FIND1^DIC(58.63,"","",CABNAME) K DIERR Q:'CABIEN "" ;*356
; Get value in SEND DWO MESSAGES field (#3) in PADE DISPENSING DEVICE file (#58.63)
K DIERR D GETS^DIQ(58.63,CABIEN_",",3,"I","RESULT","ERROR") K DIERR ;*356
Q +$G(RESULT(58.63,CABIEN_",",3,"I"))
;
GETGRPS(PSJOMS,GROUPS) ; Find Entity mail group in mail group variable pointer field
; DWO MAIL GROUP (#3) in the PADE INVENTORY SYSTEM file (58.601)
;
; Input: PSJOMS("DISPSYS") = Inbound Dispensing System name.
; PSJOMS("CABID") = PADE cabinet name.
;
; Output: GROUPS(EntityPointer,Count)=MailGroupName
;
; Dispensed Without Orders (DWO) mail groups may be associated with up to seven entities.
; Each entity is associated with a precedence level, creating a hierarchy such that only mail groups
; associated with the entity(ies) with the highest precedence will receive a DWO message.
;
; If two entities have the same precedence, and both have DWO mail groups defined, both will receive
; a DWO message. For example, if an incoming PADE inventory HL7 message is associated with a cabinet
; that does not have a DWO mail group defined, but the cabinet is associated with a ward and a clinic,
; each of which DOES have a DWO mail group defined, the DWO message will go the both the ward mail
; group and the clinic mail group, because the ward and the clinic have the same precedence.
;
; If none of the entities associated with an incoming PADE inventory HL7 message is associated with
; a DWO mail group, no DWO message is sent.
;
; PADE DWO message entities, in order of precedence
; 1)PADE CABINET : PADE DISPENSING DEVICE file (#58.63)
; 2)........WARD : WARD LOCATION file (#42)
; ........CLINIC : HOSPITAL LOCATION file (#44)
; 3)..WARD GROUP : WARD GROUP file (#57.5)
; ..CLINIC GROUP : CLINIC GROUP file (#57.8)
; 4).PADE SYSTEM : PADE INVENTORY SYSTEM file (#58.601)
; ......DIVISION : DIVISION file (#40.8)
;
N PSJPSYS,PSJECNT,PSJMCT,PSJDWINS,PSJDWMG,PSJRSLT,PSJRSLT1,PSJDWENT,PRIO,TEMPGRP,PSJHI,NEXT
K GROUPS N PSJCL,PSJCLGRP,PSJWRD,PSJWGRP,PSJCAB,PSJDIV,PSJFICHK,PSJENTYP
; Get PADE Inbound System pointer to file 58.601, store in "FICHK" node
S PSJPSYS=$G(PSJOMS("DISPSYS")) Q:(PSJPSYS="") 0
K DIERR S PSJPSYS=$$FIND1^DIC(58.601,"","",PSJPSYS) K DIERR Q:'PSJPSYS 0 ;*356
S PSJPSYS("FICHK",PSJPSYS)=PSJOMS("DISPSYS")
; Get PADE Cabinet pointer to file 58.63, store in "FICHK" node
K DIERR S PSJCAB=+$$FIND1^DIC(58.63,,,PSJOMS("CABID")),PSJCAB("FICHK",PSJCAB)=PSJOMS("CABID") K DIERR ;*356
K DIERR D GETS^DIQ(58.63,PSJCAB,2,"IE","PSJDIV") K DIERR ;*356
; Get PADE device Division pointer to file 40.8, store in "FICHK" node
S PSJDIV("FICHK",+$G(PSJDIV(58.63,PSJCAB_",",2,"I")))=$G(PSJDIV(58.63,PSJCAB_",",2,"E"))
; Get PADE device Clinic pointer to file 44, store in "FICHK" node
D LIST^DIC(58.638,","_PSJCAB_",",".01IE","P",,,,,,,"PSJCL") N CL,CC S CC=0 F S CC=$O(PSJCL("DILIST",CC)) Q:'CC D
.S CL=$P($G(PSJCL("DILIST",CC,0)),"^",3) I CL S PSJCL("FICHK",+CL)=$P(PSJCL("DILIST",CC,0),"^",2)
K PSJCL("DILIST")
; Get PADE device Clinic Group pointer to file 57.8, store in "FICHK" node
D LIST^DIC(58.637,","_PSJCAB_",",".01IE","P",,,,,,,"PSJCLGRP") N CG,CC S CC=0 F S CC=$O(PSJCLGRP("DILIST",CC)) Q:'CC D
.S CG=$P($G(PSJCLGRP("DILIST",CC,0)),"^",3) I CG S PSJCLGRP("FICHK",+CG)=$P(PSJCLGRP("DILIST",CC,0),"^",2)
K PSJCLGRP("DILIST")
; Get PADE device Ward pointer to file 42, store in "FICHK" node
D LIST^DIC(58.636,","_PSJCAB_",",".01IE","P",,,,,,,"PSJWRD") N WD,WC S WC=0 F S WC=$O(PSJWRD("DILIST",WC)) Q:'WC D
.S WD=$P($G(PSJWRD("DILIST",WC,0)),"^",3) I WD S PSJWRD("FICHK",+WD)=$P(PSJWRD("DILIST",WC,0),"^",2)
K PSJWRD("DILIST")
; Get PADE Ward Group pointer to file 57.5, store in "FICHK" node
D LIST^DIC(58.635,","_PSJCAB_",",".01IE","P",,,,,,,"PSJWGRP") N WG,WC S WC=0 F S WC=$O(PSJWGRP("DILIST",WC)) Q:'WC D
.S WG=$P($G(PSJWGRP("DILIST",WC,0)),"^",3) I WG S PSJWGRP("FICHK",+WG)=$P(PSJWGRP("DILIST",WC,0),"^",2)
K PSJWGRP("DILIST")
; Get list of DWO MESSAGE ENTITY values for PADE system in PSJRSLT
D LIST^DIC(58.6014,","_+PSJPSYS_",",.01,"P",,,,,,,"PSJRSLT","PSJROOT")
;
; Go through each DWO MESSAGE ENTITY, determine if the entity applies to this cabinet/device
; by comparing each DWO MESSAGE ENTITY to the list of entities defined for the cabinet.
;
S PSJECNT=0 F S PSJECNT=$O(PSJRSLT("DILIST",PSJECNT)) Q:'PSJECNT D
.; Find the source file pointed to by the variable pointer DWO MESSAGE ENTITY field (#4) in the PADE INVENTORY SYSTEM file (#58.601)
.S PSJDWINS=+$G(PSJRSLT("DILIST",PSJECNT,0))
.; Get list of mail groups associated with this entity
.D LIST^DIC(58.60141,","_+PSJDWINS_","_+PSJPSYS_",",.01,"P",,,,,,,"PSJRSLT1")
.S PSJDWENT=$G(^PS(58.601,PSJPSYS,2,PSJDWINS,0))
.; Define priority for this entity
.S PSJENTYP=$S(PSJDWENT["PS(58.63":"1^PSJCAB",PSJDWENT["DG(40.8":"4^PSJDIV",PSJDWENT["PS(58.601":"4^PSJPSYS",PSJDWENT["DIC(42":"2^PSJWRD",PSJDWENT["PS(57.8":"3^PSJCLGRP",PSJDWENT["PS(57.5":"3^PSJWGRP",PSJDWENT["SC(":"2^PSJCL",1:99)
.S PRIO=+PSJENTYP ;S PRIO=$S((PSJDWENT[58.63):1,(PSJDWENT["DIC(42,")!(PSJDWENT["SC("):2,(PSJDWENT[57.5)!(PSJDWENT[57.8):3,(PSJDWENT[58.601)!(PSJDWENT[40.8):4,1:99)
.; Quit if this DWO MESSAGE ENTITY from PADE INVENTORY SYSTEM (#58.601) is not applicable to this PADE DISPENSING DEVICE (#58.63)
.S PSJFICHK=$P(PSJENTYP,"^",2)_"(""FICHK"","_+PSJDWENT_")" Q:'$D(@PSJFICHK)
.; Go through mail groups, set into TMPGRP by priority
.S PSJMCT=0 F S PSJMCT=$O(PSJRSLT1("DILIST",PSJMCT)) Q:'PSJMCT D
..S PSJDWMG=$G(PSJRSLT1("DILIST",PSJMCT,0)) Q:'PSJDWMG
..S NEXT=+$O(TEMPGRP(PRIO,PSJDWENT,999),-1)+1
..S TEMPGRP(PRIO,PSJDWENT,NEXT)=$P(PSJDWMG,"^",2)
;
; Move highest priority entity mail groups into GROUPS
S PSJHI=$O(TEMPGRP("")) I PSJHI]"" M GROUPS=TEMPGRP(PSJHI)
Q
;
DWOSEND(PSJOMS,GROUPS) ;This routine will generate a mailman message when an order is dispensed without an order, and a DWO mail group is defined
;
;Input: PSJOMS - Array generated from incoming OMS^O05 HL7 PADE pocket activity message
; GROUPS - VistA Mail Groups to send the DWO message
;
N MSGTEXT,XMTEXT,XMSUB,XMY,XMZ,XMDUZ,MSGTYPE,MSHREC,ENTITY,MAILGRP
N HLFS,HLCS,MTXTLN,MGCNT,DRGFILNM
S DRGFILNM="" I $G(PSJOMS("DRGITM")) S:PSJOMS("DRGITM")=+PSJOMS("DRGITM") DRGFILNM=$P($G(^PSDRUG(PSJOMS("DRGITM"),0)),"^")
I DRGFILNM="" S DRGFILNM=$G(PSJOMS("DRGTXT"))
S:'$G(PSJOMS("PSJDT")) PSJOMS("PSJDT")=$P($$FMTHL7^XLFDT($$NOW^XLFDT()),"-")
Q:'($G(PSJOMS("TTYPE"))["V")
S MTXTLN=0
S MSGTEXT(MTXTLN)=" ",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="A medication was dispensed from a PADE device without an order",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)=" ",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="PADE Device: "_$G(PSJOMS("CABID")),MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="Date: "_$$FMTE^XLFDT($$FMDATE^HLFNC(PSJOMS("PSJDT"))),MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="Drug: "_DRGFILNM,MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="Patient: "_$G(PSJOMS("PTNAMA"))_","_$G(PSJOMS("PTNAMB"))_" "_$G(PSJOMS("PTNAMC")) D
.S MSGTEXT(MTXTLN)=MSGTEXT(MTXTLN)_" "_$S($G(PSJOMS("SSN")):" ("_$G(PSJOMS("SSN"))_")",$G(PSJOMS("PTID"))]"":"(Unknown ID: "_$G(PSJOMS("PTID"))_")",1:" ()"),MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="",MTXTLN=MTXTLN+1
S MSGTEXT(MTXTLN)="User: "_$G(PSJOMS("NUR1B"))_$S($G(PSJOMS("NUR1C"))]"":","_PSJOMS("NUR1C"),1:"")_" - ID: "_$G(PSJOMS("NUR1A")),MTXTLN=MTXTLN+1
; Send message to mail groups
S XMSUB="PADE DWO:"_$G(PSJOMS("CABID"))_"-"_DRGFILNM
S XMTEXT="MSGTEXT("
I $D(GROUPS)>1 S ENTITY="" F S ENTITY=$O(GROUPS(ENTITY)) Q:ENTITY="" D
.S MGCNT=0 F S MGCNT=$O(GROUPS(ENTITY,MGCNT)) Q:'MGCNT D
..S MAILGRP=GROUPS(ENTITY,MGCNT) Q:MAILGRP=""
..S XMY("G."_MAILGRP)=""
I $D(XMY)<10 D GETPDMGR^PSJPAD7I(.XMY)
Q:$D(XMY)<10
S XMDUZ="PADE-SYSTEM"
D ^XMD
Q
;
UNLOAD(PSJPSYS,PADIEN,DRWIEN,DRGIEN,DRGDEV,PCKIEN) ; Unload (delete) a drug from pocket and drawer for device DEV and system SYS
; INPUT
; PSJPSYS - Inventory System entry from file 58.601
; PADIEN - Dispensing Device (#1) field (subfile 58.6011) from file 58.601
; DRWIEN - Drawer (#2) field (subfile 58.60112) from dispensing device subfile (#58.60111) in file 58.601
; DRGIEN - Drug (Drawer) (#1) field (subfile 58.601121) from drawer subfile (#58.60112) in file 58.61
; DRGDEV - Drug (Device) (#2) field (subfile 58.60111) from dispensing device subfile (#58.6011) in file 58.601
; PCKIEN - Pocket/Subdrawer (#2) field (subfile 58.601122) from drawer subfile (58.60112) in file 58.601
;
N DIK,DA,PSERR
; If the unique location in the device,
I $G(PSJPSYS)&$G(PADIEN)&$G(DRWIEN) I $D(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRAWER",+DRWIEN)) D
.S DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRAWER"","_+DRWIEN_",""SUB"","
.S DA(3)=+PSJPSYS,DA(2)=+PADIEN,DA(1)=DRWIEN,DA=PCKIEN D ^DIK
.S DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRAWER"","_+DRWIEN_",""DRUG"","
.S DA(3)=+PSJPSYS,DA(2)=+PADIEN,DA(1)=DRWIEN,DA=DRGIEN D ^DIK
;
; Kill Drug (DEVICE) only if balance is less than 1
N DA,DIK,DEVBAL
S DEVBAL=$P($G(^PS(58.601,+$G(PSJPSYS),"DEVICE",+$G(PADIEN),"DRUG",+$G(DRGDEV),0)),"^",3)
Q:DEVBAL>0 ; Don't delete drug from device/cabinet/station if there it's stocked somewhere else
S DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRUG"","
S DA(2)=+PSJPSYS,DA(1)=+PADIEN,DA=DRGDEV D ^DIK
Q
;
MANUN(PADEV) ; Manually unload one drug at a time from PADE INVENTORY SYSTEM (#58.601) file for device PADEV pointer to DISPENSING DEVICE (#58.63) file
; Input : PADEV - Pointer to PADE DISPENSING DEVICE (#58.63) file
;
N DIR,X,Y
S DIR(0)="Y",DIR("A")="DELETE SINGLE DRUG FROM PADE CABINET"
S DIR("?")="^D UNLHLP^PSJPAD70"
S DIR("B")="N" D ^DIR
Q:'Y
; User wants to go through with removing drug from device
N PSJSTOP S PSJSTOP=0
F Q:$G(PSJSTOP) D UNLDONE(PADEV)
Q
;
UNLDONE(PADEV) ; Manually unload a drug from a pocket
; Input : PADIEN = PADE Dispensing Device IEN (required)
;
N PSJINP,PSDRG,PSJCSUB,SCHLST,PADIEN,DRWIEN,DRGIEN,DRGDEV,PCKIEN,DRWPCK,DRGDEV,PSJDRC,DRUG
S PSJSTOP=0,DRWPCK="",DRWIEN="",DRGIEN="",PCKIEN=""
Q:'$G(PADEV) ; Quit if device IEN not passed in
S PSJPSYS=$P($G(^PS(58.63,+PADEV,0)),"^",2)
Q:'$G(PSJPSYS) ; Quit if device not in inventory file
; Get internal pointer to device from inventory file
S PADIEN=$O(^PS(58.601,+PSJPSYS,"DEVICE","B",+PADEV,""))
S PSJINP("PADEV",PADEV)="",PSJINP("PADEV")=PADEV
S PSJINP("PSJPSYS")=PSJPSYS
; Find drugs stocked in device, all CS schedules
S SCHLST="1:Schedule I;2:Schedule II;2n:Schedule II Non-Narcotics;3:Schedule III;3n:Schedule III Non-Narcotics;4:Schedule IV;5:Schedule V"
S PSJCSUB="ALL" D ALLSCHED^PSJPDRIP(.PSJCSUB,SCHLST) S PSJCSUB="ALL" M PSJINP("PSJCSUB")=PSJCSUB
S PSJINP("PSJCSUB",0)="Unscheduled"
S PSJINP("MANUNLOD")=1
D DRCAB^PSJPDRIN(.PSJINP,.PSJDRC)
; Prompt user to select drug
D DRUGSEL^PSJPDRTR(.PSJINP,.PSJDRC,.DRUG,.DRWPCK,.PSJSTOP) ; Prompt for drug items
I $G(DRWPCK)="" S PSJSTOP=1
Q:$G(PSJSTOP) ; nothing selected
; If ALL drugs selected, reset device and quit
I DRWPCK="ALL" S PSJINP("PSDRG")="ALL" D ASKRESET^PSJPADPT(PADEV) Q
N PCKSTR,SELCNT,PCKCNT,PSJSELY,PCKSEL,DIR
S PCKSTR="",PCKCNT=0
; If specific drugs selected, find pockets containing drug, display for selection
I DRWPCK'="ALL" S PSJINP("PSDRG")=DRWPCK D
.N POCKET
.S DRWIEN=0 F S DRWIEN=$O(DRWPCK(DRWPCK,DRWIEN)) Q:'DRWIEN D
..S POCKET=0 F S POCKET=$O(DRWPCK(DRWPCK,DRWIEN,POCKET)) Q:'POCKET D
...N PCKNAME,DRGDRW,SUBID
...S PCKNAME=$P($G(DRWPCK(DRWPCK,DRWIEN,POCKET)),"^")
...S DRGDRW=$P($G(DRWPCK(DRWPCK,DRWIEN,POCKET)),"^",2)
...S SUBID=$P($P($G(DRWPCK(DRWPCK,DRWIEN,POCKET)),"^",4),"~~") S:SUBID="" SUBID="-"
...S PCKSEL=PCKCNT+1_":"_PCKNAME
...S PCKSEL(PCKCNT+1)=DRWPCK_"^"_DRWIEN_"^"_POCKET_"^"_PCKNAME_"^"_DRGDRW_$S($L(SUBID):"^"_SUBID,1:"")
...I PCKCNT=0 S PCKSTR=PCKSEL,PCKCNT=PCKCNT+1 Q
...S PCKSTR=$G(PCKSTR)_";"_PCKSEL
...S PCKCNT=PCKCNT+1
.Q:'PCKCNT
.S DIR(0)="SA^"_PCKSTR,DIR("A")="Select Pocket: "
.F SELCNT=1:1:$L(PCKSTR,";") Q:$P(PCKSTR,";",SELCNT)="" D
..N SUBID S SUBID=$P($G(PCKSEL(SELCNT)),"^",6)
..S DIR("A",SELCNT)=" "_$P($P(PCKSTR,";",SELCNT),":")_" - Drawer "_$P($P($P(PCKSTR,";",SELCNT),":",2),"_")_" Pocket "_$P($P($P(PCKSTR,";",SELCNT),":",2),"_",2)_$S($L(SUBID):" Subdrawer: "_SUBID,1:"")
.D ^DIR I Y'>0 S PSJSTOP=1 Q
.S PSJSELY=$G(PCKSEL(+Y))
; Get sub-file pointers to drawer and pocket selected by user
Q:$G(PSJSTOP)
S DRWIEN=$P($G(PSJSELY),"^",2)
S PCKIEN=$P($G(PSJSELY),"^",3)
S DRGDRW=$P($G(PSJSELY),"^",5)
S DRGDEV=$G(DRWPCK(DRWPCK,"DRGDEV"))
; If the drug is not stocked in more than one pocket, set the device balance to zero so the UNLOAD removes it completely from device
I '(PCKCNT>1) D
.S DEVBAL=$P($G(^PS(58.601,+$G(PSJPSYS),"DEVICE",+$G(PADIEN),"DRUG",+$G(DRGDEV),0)),"^",3)
.I DEVBAL S $P(^PS(58.601,+$G(PSJPSYS),"DEVICE",+$G(PADIEN),"DRUG",+$G(DRGDEV),0),"^",3)=0
D UNLOAD(PSJPSYS,PADIEN,DRWIEN,DRGDRW,DRGDEV,PCKIEN)
W " ...Done."
N DIR,X,Y S DIR(0)="Y"
S DIR("A")="Delete another drug"
D ^DIR
I '$G(Y) S PSJSTOP=1
Q
;
UNLHLP ; Display help text explaining PADE manual unload
N HELPAR
S HELPAR(1)="This action removes one drug item from a specific pocket from this"
S HELPAR(2)="PADE dispensing device in VistA. Manually deleting a drug item does"
S HELPAR(3)="not affect the PADE vendor, and does not trigger any HL7 messages to"
S HELPAR(4)="the PADE vendor system. Manually deleting a drug item reduces the"
S HELPAR(5)="quantity of the drug that displays as available in VistA when running"
S HELPAR(6)="the PADE INVENTORY REPORT, and also removes the drug from balances"
S HELPAR(7)="displayed in Inpatient Order Entry."
S HELPAR(8)="After a drug is deleted, the drug may be added back to the cabinet's"
S HELPAR(9)="inventory as new HL7 messages are received from the vendor."
D EN^DDIOL(.HELPAR)
Q
;
OLDPKUP(TMPADATA,ERRMSG,PS586IEN) ; Return 1 if data in TMPADATA indicates this pocket was updated more recently than the current transaction's date/time
N POCKSUB ; POCKET_SUBDRAWER concatenated
N PSPRVDT ; The last transaction date/time (date/time of the activity at the cabinet) this pocket was updated
N PSPRVDIE ; The IEN of the last transaction date/time in the "PKUPDT" multiple
N FDA,PSJPSYS,PSJSCR,PSJSCR
;
K DIERR,ERR S TMPADATA("SYS IEN")=$$FIND1^DIC(58.601,"","MX",$G(TMPADATA(1)),,,"ERR") K DIERR ;*356
I '$G(TMPADATA("SYS IEN")) Q 0
;
I '($G(TMPADATA(2))]"") Q 0
I $G(PSJPSYS),$G(^PS(58.601,+PSJPSYS,0))]"" S TMPADATA("SYS IEN")=PSJPSYS
S PSJPSYS=TMPADATA("SYS IEN"),PSJSCR="I $S('$G(PSJPSYS):1,1:PSJPSYS=$P(^(0),U,2))"
I ($G(TMPADATA(1))=""&$G(PSJPSYS)) S TMPADATA(1)=$P(^PS(58.601,PSJPSYS,0),"^")
K ERR,DIERR S TMPADATA("DEVICE IEN")=$$FIND1^DIC(58.63,,"BX",TMPADATA(2),,PSJSCR,"ERR") K DIERR ;*356
Q:'$G(TMPADATA("DEVICE IEN")) 0
S TMPADATA("DEVICE IEN")=$O(^PS(58.601,+$G(TMPADATA("SYS IEN")),"DEVICE","B",TMPADATA("DEVICE IEN"),0))
Q:'$G(TMPADATA("DEVICE IEN")) 0
;
I $G(TMPADATA(3))="" S TMPADATA(3)="zz"
S TMPADATA("DRAWER IEN")=$O(^PS(58.601,+$G(TMPADATA("SYS IEN")),"DEVICE",+$G(TMPADATA("DEVICE IEN")),"DRAWER","B",$G(TMPADATA(3)),0))
I '$G(TMPADATA("DRAWER IEN")) Q 0
;
N DRUG,DEVIEN,SYSIEN
S DRUG=$G(TMPADATA(4)) ; Drug
S DEVIEN=$G(TMPADATA("DEVICE IEN")) ; Dispensing Device IEN
S SYSIEN=$G(TMPADATA("SYS IEN")) ; PADE System IEN
I '(DRUG]"") Q 0 ; No drug, no go
I '$D(^PSDRUG(DRUG,0)) Q 0 ; No valid drug
; Must have PADE system and Dispensing Device
I '$G(DEVIEN) Q 0
I '$G(SYSIEN) Q 0
;
N DA,FDA,X,Y,DIC,DIE,DR,D0,ERR,D,DD,DICR,DICRS,DO
S TMPADATA("DRUG DEV IEN")=$$FIND1^DIC(58.60111,","_DEVIEN_","_SYSIEN_",","MXQ",DRUG,,,"ERR") K DIERR ;*356
;
S TMPADATA(10)=$TR(TMPADATA(10),"~~")_"~~"_+$G(TMPADATA(4)) ; Append subdrawer unique drug IEN suffix to handle different drugs in same subdr-pocket combo
S:$G(TMPADATA(10))="" TMPADATA(10)=$P($G(^PS(58.6,+$G(PS586IEN),0)),"^",12) S:TMPADATA(10)="" TMPADATA(10)="~~"_+$G(TMPADATA(4))
S POCKSUB=$G(TMPADATA(7))_"_"_$G(TMPADATA(10)) ; "POCKET_SUBDRAWER" storage location
K ERR,DIERR S TMPADATA("POCK/SUB IEN")=$$FIND1^DIC(58.601122,","_TMPADATA("DRAWER IEN")_","_TMPADATA("DEVICE IEN")_","_TMPADATA("SYS IEN")_",","MX",POCKSUB,,,"ERR") K DIERR ;*356
; Get the last date/time this drawer/subdrawer~drug/pocket was updated
S PSPRVDIE=$O(^PS(58.601,+$G(TMPADATA("SYS IEN")),"DEVICE",+$G(TMPADATA("DEVICE IEN")),"DRAWER",+$G(TMPADATA("DRAWER IEN")),"PKUPDT","B",POCKSUB,""))
;
S PSPRVDT=$P($G(^PS(58.601,+$G(TMPADATA("SYS IEN")),"DEVICE",+$G(TMPADATA("DEVICE IEN")),"DRAWER",+$G(TMPADATA("DRAWER IEN")),"PKUPDT",+$G(PSPRVDIE),0)),"^",2)
; If this current update contains a transaction date/time (i.e., activity date/time) older than the last update, don't update inventory
I $G(PSPRVDT)&$G(TMPADATA(9)) I TMPADATA(9)<PSPRVDT D Q 1
.S ERRMSG="- OUTDATED TRANSACTION - "_$G(TMPADATA(1))_"."_$G(TMPADATA(2))_".DRUG="_$P($G(^PSDRUG(+$G(TMPADATA(4)),0)),"^")_"("_$G(TMPADATA(4))_").POCKET="_$G(TMPADATA(7))
.S ERRMSG=ERRMSG_".LAST UPDATED="_PSPRVDT_".TRANS DT="_TMPADATA(9)
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPAD70 18545 printed Oct 16, 2024@18:09:18 Page 2
PSJPAD70 ;BIR/JCH - HL7 UTILITY FOR PADE INBOUND POCKET ACTIVITY ;01/06/16 1:34 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**317,356,376**;16 DEC 97;Build 4
+2 ;
+3 ; Reference to $$HLDATE^HLFNC is supported by DBIA 10106
+4 ; Reference to ^XMD is supported by DBIA 10070
+5 ; Reference to ^XLFDT is supported by DBIA# 10103.
+6 ;
+7 QUIT
+8 ;
DWO(PSJOMS) ; Send Dispensed Without Order (DWO) Alert
+1 NEW GROUPS
+2 SET GROUPS=""
+3 if '$$ACTDWO(.PSJOMS)
QUIT
+4 DO GETGRPS(.PSJOMS,.GROUPS)
+5 DO DWOSEND(.PSJOMS,.GROUPS)
+6 QUIT
+7 ;
ACTDWO(PSJOMS) ; Check if dispensing device (cabinet) is active for DWO messages
+1 NEW CABNAME,CABIEN,RESULT,ERROR,PSJPSYS
+2 ; Get PADE Inbound System name
+3 SET PSJPSYS=$GET(PSJOMS("DISPSYS"))
if (PSJPSYS="")
QUIT 0
+4 ;*356
SET PSJPSYS=$$FIND1^DIC(58.601,"","",PSJPSYS)
KILL DIERR
if 'PSJPSYS
QUIT ""
+5 ; Get Cabinet name
+6 SET CABNAME=$GET(PSJOMS("CABID"))
if (CABNAME="")
QUIT 0
+7 ;*356
KILL DIERR
SET CABIEN=$$FIND1^DIC(58.63,"","",CABNAME)
KILL DIERR
if 'CABIEN
QUIT ""
+8 ; Get value in SEND DWO MESSAGES field (#3) in PADE DISPENSING DEVICE file (#58.63)
+9 ;*356
KILL DIERR
DO GETS^DIQ(58.63,CABIEN_",",3,"I","RESULT","ERROR")
KILL DIERR
+10 QUIT +$GET(RESULT(58.63,CABIEN_",",3,"I"))
+11 ;
GETGRPS(PSJOMS,GROUPS) ; Find Entity mail group in mail group variable pointer field
+1 ; DWO MAIL GROUP (#3) in the PADE INVENTORY SYSTEM file (58.601)
+2 ;
+3 ; Input: PSJOMS("DISPSYS") = Inbound Dispensing System name.
+4 ; PSJOMS("CABID") = PADE cabinet name.
+5 ;
+6 ; Output: GROUPS(EntityPointer,Count)=MailGroupName
+7 ;
+8 ; Dispensed Without Orders (DWO) mail groups may be associated with up to seven entities.
+9 ; Each entity is associated with a precedence level, creating a hierarchy such that only mail groups
+10 ; associated with the entity(ies) with the highest precedence will receive a DWO message.
+11 ;
+12 ; If two entities have the same precedence, and both have DWO mail groups defined, both will receive
+13 ; a DWO message. For example, if an incoming PADE inventory HL7 message is associated with a cabinet
+14 ; that does not have a DWO mail group defined, but the cabinet is associated with a ward and a clinic,
+15 ; each of which DOES have a DWO mail group defined, the DWO message will go the both the ward mail
+16 ; group and the clinic mail group, because the ward and the clinic have the same precedence.
+17 ;
+18 ; If none of the entities associated with an incoming PADE inventory HL7 message is associated with
+19 ; a DWO mail group, no DWO message is sent.
+20 ;
+21 ; PADE DWO message entities, in order of precedence
+22 ; 1)PADE CABINET : PADE DISPENSING DEVICE file (#58.63)
+23 ; 2)........WARD : WARD LOCATION file (#42)
+24 ; ........CLINIC : HOSPITAL LOCATION file (#44)
+25 ; 3)..WARD GROUP : WARD GROUP file (#57.5)
+26 ; ..CLINIC GROUP : CLINIC GROUP file (#57.8)
+27 ; 4).PADE SYSTEM : PADE INVENTORY SYSTEM file (#58.601)
+28 ; ......DIVISION : DIVISION file (#40.8)
+29 ;
+30 NEW PSJPSYS,PSJECNT,PSJMCT,PSJDWINS,PSJDWMG,PSJRSLT,PSJRSLT1,PSJDWENT,PRIO,TEMPGRP,PSJHI,NEXT
+31 KILL GROUPS
NEW PSJCL,PSJCLGRP,PSJWRD,PSJWGRP,PSJCAB,PSJDIV,PSJFICHK,PSJENTYP
+32 ; Get PADE Inbound System pointer to file 58.601, store in "FICHK" node
+33 SET PSJPSYS=$GET(PSJOMS("DISPSYS"))
if (PSJPSYS="")
QUIT 0
+34 ;*356
KILL DIERR
SET PSJPSYS=$$FIND1^DIC(58.601,"","",PSJPSYS)
KILL DIERR
if 'PSJPSYS
QUIT 0
+35 SET PSJPSYS("FICHK",PSJPSYS)=PSJOMS("DISPSYS")
+36 ; Get PADE Cabinet pointer to file 58.63, store in "FICHK" node
+37 ;*356
KILL DIERR
SET PSJCAB=+$$FIND1^DIC(58.63,,,PSJOMS("CABID"))
SET PSJCAB("FICHK",PSJCAB)=PSJOMS("CABID")
KILL DIERR
+38 ;*356
KILL DIERR
DO GETS^DIQ(58.63,PSJCAB,2,"IE","PSJDIV")
KILL DIERR
+39 ; Get PADE device Division pointer to file 40.8, store in "FICHK" node
+40 SET PSJDIV("FICHK",+$GET(PSJDIV(58.63,PSJCAB_",",2,"I")))=$GET(PSJDIV(58.63,PSJCAB_",",2,"E"))
+41 ; Get PADE device Clinic pointer to file 44, store in "FICHK" node
+42 DO LIST^DIC(58.638,","_PSJCAB_",",".01IE","P",,,,,,,"PSJCL")
NEW CL,CC
SET CC=0
FOR
SET CC=$ORDER(PSJCL("DILIST",CC))
if 'CC
QUIT
Begin DoDot:1
+43 SET CL=$PIECE($GET(PSJCL("DILIST",CC,0)),"^",3)
IF CL
SET PSJCL("FICHK",+CL)=$PIECE(PSJCL("DILIST",CC,0),"^",2)
End DoDot:1
+44 KILL PSJCL("DILIST")
+45 ; Get PADE device Clinic Group pointer to file 57.8, store in "FICHK" node
+46 DO LIST^DIC(58.637,","_PSJCAB_",",".01IE","P",,,,,,,"PSJCLGRP")
NEW CG,CC
SET CC=0
FOR
SET CC=$ORDER(PSJCLGRP("DILIST",CC))
if 'CC
QUIT
Begin DoDot:1
+47 SET CG=$PIECE($GET(PSJCLGRP("DILIST",CC,0)),"^",3)
IF CG
SET PSJCLGRP("FICHK",+CG)=$PIECE(PSJCLGRP("DILIST",CC,0),"^",2)
End DoDot:1
+48 KILL PSJCLGRP("DILIST")
+49 ; Get PADE device Ward pointer to file 42, store in "FICHK" node
+50 DO LIST^DIC(58.636,","_PSJCAB_",",".01IE","P",,,,,,,"PSJWRD")
NEW WD,WC
SET WC=0
FOR
SET WC=$ORDER(PSJWRD("DILIST",WC))
if 'WC
QUIT
Begin DoDot:1
+51 SET WD=$PIECE($GET(PSJWRD("DILIST",WC,0)),"^",3)
IF WD
SET PSJWRD("FICHK",+WD)=$PIECE(PSJWRD("DILIST",WC,0),"^",2)
End DoDot:1
+52 KILL PSJWRD("DILIST")
+53 ; Get PADE Ward Group pointer to file 57.5, store in "FICHK" node
+54 DO LIST^DIC(58.635,","_PSJCAB_",",".01IE","P",,,,,,,"PSJWGRP")
NEW WG,WC
SET WC=0
FOR
SET WC=$ORDER(PSJWGRP("DILIST",WC))
if 'WC
QUIT
Begin DoDot:1
+55 SET WG=$PIECE($GET(PSJWGRP("DILIST",WC,0)),"^",3)
IF WG
SET PSJWGRP("FICHK",+WG)=$PIECE(PSJWGRP("DILIST",WC,0),"^",2)
End DoDot:1
+56 KILL PSJWGRP("DILIST")
+57 ; Get list of DWO MESSAGE ENTITY values for PADE system in PSJRSLT
+58 DO LIST^DIC(58.6014,","_+PSJPSYS_",",.01,"P",,,,,,,"PSJRSLT","PSJROOT")
+59 ;
+60 ; Go through each DWO MESSAGE ENTITY, determine if the entity applies to this cabinet/device
+61 ; by comparing each DWO MESSAGE ENTITY to the list of entities defined for the cabinet.
+62 ;
+63 SET PSJECNT=0
FOR
SET PSJECNT=$ORDER(PSJRSLT("DILIST",PSJECNT))
if 'PSJECNT
QUIT
Begin DoDot:1
+64 ; Find the source file pointed to by the variable pointer DWO MESSAGE ENTITY field (#4) in the PADE INVENTORY SYSTEM file (#58.601)
+65 SET PSJDWINS=+$GET(PSJRSLT("DILIST",PSJECNT,0))
+66 ; Get list of mail groups associated with this entity
+67 DO LIST^DIC(58.60141,","_+PSJDWINS_","_+PSJPSYS_",",.01,"P",,,,,,,"PSJRSLT1")
+68 SET PSJDWENT=$GET(^PS(58.601,PSJPSYS,2,PSJDWINS,0))
+69 ; Define priority for this entity
+70 SET PSJENTYP=$SELECT(PSJDWENT["PS(58.63":"1^PSJCAB",PSJDWENT["DG(40.8":"4^PSJDIV",PSJDWENT["PS(58.601":"4^PSJPSYS",PSJDWENT["DIC(42":"2^PSJWRD",PSJDWENT["PS(57.8":"3^PSJCLGRP",PSJDWENT["PS(57.5":"3^PSJWGRP",PSJDWENT["SC(":"2^PSJCL",1:99
)
+71 ;S PRIO=$S((PSJDWENT[58.63):1,(PSJDWENT["DIC(42,")!(PSJDWENT["SC("):2,(PSJDWENT[57.5)!(PSJDWENT[57.8):3,(PSJDWENT[58.601)!(PSJDWENT[40.8):4,1:99)
SET PRIO=+PSJENTYP
+72 ; Quit if this DWO MESSAGE ENTITY from PADE INVENTORY SYSTEM (#58.601) is not applicable to this PADE DISPENSING DEVICE (#58.63)
+73 SET PSJFICHK=$PIECE(PSJENTYP,"^",2)_"(""FICHK"","_+PSJDWENT_")"
if '$DATA(@PSJFICHK)
QUIT
+74 ; Go through mail groups, set into TMPGRP by priority
+75 SET PSJMCT=0
FOR
SET PSJMCT=$ORDER(PSJRSLT1("DILIST",PSJMCT))
if 'PSJMCT
QUIT
Begin DoDot:2
+76 SET PSJDWMG=$GET(PSJRSLT1("DILIST",PSJMCT,0))
if 'PSJDWMG
QUIT
+77 SET NEXT=+$ORDER(TEMPGRP(PRIO,PSJDWENT,999),-1)+1
+78 SET TEMPGRP(PRIO,PSJDWENT,NEXT)=$PIECE(PSJDWMG,"^",2)
End DoDot:2
End DoDot:1
+79 ;
+80 ; Move highest priority entity mail groups into GROUPS
+81 SET PSJHI=$ORDER(TEMPGRP(""))
IF PSJHI]""
MERGE GROUPS=TEMPGRP(PSJHI)
+82 QUIT
+83 ;
DWOSEND(PSJOMS,GROUPS) ;This routine will generate a mailman message when an order is dispensed without an order, and a DWO mail group is defined
+1 ;
+2 ;Input: PSJOMS - Array generated from incoming OMS^O05 HL7 PADE pocket activity message
+3 ; GROUPS - VistA Mail Groups to send the DWO message
+4 ;
+5 NEW MSGTEXT,XMTEXT,XMSUB,XMY,XMZ,XMDUZ,MSGTYPE,MSHREC,ENTITY,MAILGRP
+6 NEW HLFS,HLCS,MTXTLN,MGCNT,DRGFILNM
+7 SET DRGFILNM=""
IF $GET(PSJOMS("DRGITM"))
if PSJOMS("DRGITM")=+PSJOMS("DRGITM")
SET DRGFILNM=$PIECE($GET(^PSDRUG(PSJOMS("DRGITM"),0)),"^")
+8 IF DRGFILNM=""
SET DRGFILNM=$GET(PSJOMS("DRGTXT"))
+9 if '$GET(PSJOMS("PSJDT"))
SET PSJOMS("PSJDT")=$PIECE($$FMTHL7^XLFDT($$NOW^XLFDT()),"-")
+10 if '($GET(PSJOMS("TTYPE"))["V")
QUIT
+11 SET MTXTLN=0
+12 SET MSGTEXT(MTXTLN)=" "
SET MTXTLN=MTXTLN+1
+13 SET MSGTEXT(MTXTLN)="A medication was dispensed from a PADE device without an order"
SET MTXTLN=MTXTLN+1
+14 SET MSGTEXT(MTXTLN)=" "
SET MTXTLN=MTXTLN+1
+15 SET MSGTEXT(MTXTLN)="PADE Device: "_$GET(PSJOMS("CABID"))
SET MTXTLN=MTXTLN+1
+16 SET MSGTEXT(MTXTLN)=""
SET MTXTLN=MTXTLN+1
+17 SET MSGTEXT(MTXTLN)="Date: "_$$FMTE^XLFDT($$FMDATE^HLFNC(PSJOMS("PSJDT")))
SET MTXTLN=MTXTLN+1
+18 SET MSGTEXT(MTXTLN)=""
SET MTXTLN=MTXTLN+1
+19 SET MSGTEXT(MTXTLN)="Drug: "_DRGFILNM
SET MTXTLN=MTXTLN+1
+20 SET MSGTEXT(MTXTLN)=""
SET MTXTLN=MTXTLN+1
+21 SET MSGTEXT(MTXTLN)="Patient: "_$GET(PSJOMS("PTNAMA"))_","_$GET(PSJOMS("PTNAMB"))_" "_$GET(PSJOMS("PTNAMC"))
Begin DoDot:1
+22 SET MSGTEXT(MTXTLN)=MSGTEXT(MTXTLN)_" "_$SELECT($GET(PSJOMS("SSN")):" ("_$GET(PSJOMS("SSN"))_")",$GET(PSJOMS("PTID"))]"":"(Unknown ID: "_$GET(PSJOMS("PTID"))_")",1:" ()")
SET MTXTLN=MTXTLN+1
End DoDot:1
+23 SET MSGTEXT(MTXTLN)=""
SET MTXTLN=MTXTLN+1
+24 SET MSGTEXT(MTXTLN)="User: "_$GET(PSJOMS("NUR1B"))_$SELECT($GET(PSJOMS("NUR1C"))]"":","_PSJOMS("NUR1C"),1:"")_" - ID: "_$GET(PSJOMS("NUR1A"))
SET MTXTLN=MTXTLN+1
+25 ; Send message to mail groups
+26 SET XMSUB="PADE DWO:"_$GET(PSJOMS("CABID"))_"-"_DRGFILNM
+27 SET XMTEXT="MSGTEXT("
+28 IF $DATA(GROUPS)>1
SET ENTITY=""
FOR
SET ENTITY=$ORDER(GROUPS(ENTITY))
if ENTITY=""
QUIT
Begin DoDot:1
+29 SET MGCNT=0
FOR
SET MGCNT=$ORDER(GROUPS(ENTITY,MGCNT))
if 'MGCNT
QUIT
Begin DoDot:2
+30 SET MAILGRP=GROUPS(ENTITY,MGCNT)
if MAILGRP=""
QUIT
+31 SET XMY("G."_MAILGRP)=""
End DoDot:2
End DoDot:1
+32 IF $DATA(XMY)<10
DO GETPDMGR^PSJPAD7I(.XMY)
+33 if $DATA(XMY)<10
QUIT
+34 SET XMDUZ="PADE-SYSTEM"
+35 DO ^XMD
+36 QUIT
+37 ;
UNLOAD(PSJPSYS,PADIEN,DRWIEN,DRGIEN,DRGDEV,PCKIEN) ; Unload (delete) a drug from pocket and drawer for device DEV and system SYS
+1 ; INPUT
+2 ; PSJPSYS - Inventory System entry from file 58.601
+3 ; PADIEN - Dispensing Device (#1) field (subfile 58.6011) from file 58.601
+4 ; DRWIEN - Drawer (#2) field (subfile 58.60112) from dispensing device subfile (#58.60111) in file 58.601
+5 ; DRGIEN - Drug (Drawer) (#1) field (subfile 58.601121) from drawer subfile (#58.60112) in file 58.61
+6 ; DRGDEV - Drug (Device) (#2) field (subfile 58.60111) from dispensing device subfile (#58.6011) in file 58.601
+7 ; PCKIEN - Pocket/Subdrawer (#2) field (subfile 58.601122) from drawer subfile (58.60112) in file 58.601
+8 ;
+9 NEW DIK,DA,PSERR
+10 ; If the unique location in the device,
+11 IF $GET(PSJPSYS)&$GET(PADIEN)&$GET(DRWIEN)
IF $DATA(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRAWER",+DRWIEN))
Begin DoDot:1
+12 SET DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRAWER"","_+DRWIEN_",""SUB"","
+13 SET DA(3)=+PSJPSYS
SET DA(2)=+PADIEN
SET DA(1)=DRWIEN
SET DA=PCKIEN
DO ^DIK
+14 SET DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRAWER"","_+DRWIEN_",""DRUG"","
+15 SET DA(3)=+PSJPSYS
SET DA(2)=+PADIEN
SET DA(1)=DRWIEN
SET DA=DRGIEN
DO ^DIK
End DoDot:1
+16 ;
+17 ; Kill Drug (DEVICE) only if balance is less than 1
+18 NEW DA,DIK,DEVBAL
+19 SET DEVBAL=$PIECE($GET(^PS(58.601,+$GET(PSJPSYS),"DEVICE",+$GET(PADIEN),"DRUG",+$GET(DRGDEV),0)),"^",3)
+20 ; Don't delete drug from device/cabinet/station if there it's stocked somewhere else
if DEVBAL>0
QUIT
+21 SET DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRUG"","
+22 SET DA(2)=+PSJPSYS
SET DA(1)=+PADIEN
SET DA=DRGDEV
DO ^DIK
+23 QUIT
+24 ;
MANUN(PADEV) ; Manually unload one drug at a time from PADE INVENTORY SYSTEM (#58.601) file for device PADEV pointer to DISPENSING DEVICE (#58.63) file
+1 ; Input : PADEV - Pointer to PADE DISPENSING DEVICE (#58.63) file
+2 ;
+3 NEW DIR,X,Y
+4 SET DIR(0)="Y"
SET DIR("A")="DELETE SINGLE DRUG FROM PADE CABINET"
+5 SET DIR("?")="^D UNLHLP^PSJPAD70"
+6 SET DIR("B")="N"
DO ^DIR
+7 if 'Y
QUIT
+8 ; User wants to go through with removing drug from device
+9 NEW PSJSTOP
SET PSJSTOP=0
+10 FOR
if $GET(PSJSTOP)
QUIT
DO UNLDONE(PADEV)
+11 QUIT
+12 ;
UNLDONE(PADEV) ; Manually unload a drug from a pocket
+1 ; Input : PADIEN = PADE Dispensing Device IEN (required)
+2 ;
+3 NEW PSJINP,PSDRG,PSJCSUB,SCHLST,PADIEN,DRWIEN,DRGIEN,DRGDEV,PCKIEN,DRWPCK,DRGDEV,PSJDRC,DRUG
+4 SET PSJSTOP=0
SET DRWPCK=""
SET DRWIEN=""
SET DRGIEN=""
SET PCKIEN=""
+5 ; Quit if device IEN not passed in
if '$GET(PADEV)
QUIT
+6 SET PSJPSYS=$PIECE($GET(^PS(58.63,+PADEV,0)),"^",2)
+7 ; Quit if device not in inventory file
if '$GET(PSJPSYS)
QUIT
+8 ; Get internal pointer to device from inventory file
+9 SET PADIEN=$ORDER(^PS(58.601,+PSJPSYS,"DEVICE","B",+PADEV,""))
+10 SET PSJINP("PADEV",PADEV)=""
SET PSJINP("PADEV")=PADEV
+11 SET PSJINP("PSJPSYS")=PSJPSYS
+12 ; Find drugs stocked in device, all CS schedules
+13 SET SCHLST="1:Schedule I;2:Schedule II;2n:Schedule II Non-Narcotics;3:Schedule III;3n:Schedule III Non-Narcotics;4:Schedule IV;5:Schedule V"
+14 SET PSJCSUB="ALL"
DO ALLSCHED^PSJPDRIP(.PSJCSUB,SCHLST)
SET PSJCSUB="ALL"
MERGE PSJINP("PSJCSUB")=PSJCSUB
+15 SET PSJINP("PSJCSUB",0)="Unscheduled"
+16 SET PSJINP("MANUNLOD")=1
+17 DO DRCAB^PSJPDRIN(.PSJINP,.PSJDRC)
+18 ; Prompt user to select drug
+19 ; Prompt for drug items
DO DRUGSEL^PSJPDRTR(.PSJINP,.PSJDRC,.DRUG,.DRWPCK,.PSJSTOP)
+20 IF $GET(DRWPCK)=""
SET PSJSTOP=1
+21 ; nothing selected
if $GET(PSJSTOP)
QUIT
+22 ; If ALL drugs selected, reset device and quit
+23 IF DRWPCK="ALL"
SET PSJINP("PSDRG")="ALL"
DO ASKRESET^PSJPADPT(PADEV)
QUIT
+24 NEW PCKSTR,SELCNT,PCKCNT,PSJSELY,PCKSEL,DIR
+25 SET PCKSTR=""
SET PCKCNT=0
+26 ; If specific drugs selected, find pockets containing drug, display for selection
+27 IF DRWPCK'="ALL"
SET PSJINP("PSDRG")=DRWPCK
Begin DoDot:1
+28 NEW POCKET
+29 SET DRWIEN=0
FOR
SET DRWIEN=$ORDER(DRWPCK(DRWPCK,DRWIEN))
if 'DRWIEN
QUIT
Begin DoDot:2
+30 SET POCKET=0
FOR
SET POCKET=$ORDER(DRWPCK(DRWPCK,DRWIEN,POCKET))
if 'POCKET
QUIT
Begin DoDot:3
+31 NEW PCKNAME,DRGDRW,SUBID
+32 SET PCKNAME=$PIECE($GET(DRWPCK(DRWPCK,DRWIEN,POCKET)),"^")
+33 SET DRGDRW=$PIECE($GET(DRWPCK(DRWPCK,DRWIEN,POCKET)),"^",2)
+34 SET SUBID=$PIECE($PIECE($GET(DRWPCK(DRWPCK,DRWIEN,POCKET)),"^",4),"~~")
if SUBID=""
SET SUBID="-"
+35 SET PCKSEL=PCKCNT+1_":"_PCKNAME
+36 SET PCKSEL(PCKCNT+1)=DRWPCK_"^"_DRWIEN_"^"_POCKET_"^"_PCKNAME_"^"_DRGDRW_$SELECT($LENGTH(SUBID):"^"_SUBID,1:"")
+37 IF PCKCNT=0
SET PCKSTR=PCKSEL
SET PCKCNT=PCKCNT+1
QUIT
+38 SET PCKSTR=$GET(PCKSTR)_";"_PCKSEL
+39 SET PCKCNT=PCKCNT+1
End DoDot:3
End DoDot:2
+40 if 'PCKCNT
QUIT
+41 SET DIR(0)="SA^"_PCKSTR
SET DIR("A")="Select Pocket: "
+42 FOR SELCNT=1:1:$LENGTH(PCKSTR,";")
if $PIECE(PCKSTR,";",SELCNT)=""
QUIT
Begin DoDot:2
+43 NEW SUBID
SET SUBID=$PIECE($GET(PCKSEL(SELCNT)),"^",6)
+44 SET DIR("A",SELCNT)=" "_$PIECE($PIECE(PCKSTR,";",SELCNT),":")_" - Drawer "_$PIECE($PIECE($PIECE(PCKSTR,";",SELCNT),":",2),"_")_" Pocket "_$PIECE($PIECE($PIECE(PCKSTR,";",SELCNT),":",2),"_",2)_$SELECT($LENGTH(SUBID):" Subdr
awer: "_SUBID,1:"")
End DoDot:2
+45 DO ^DIR
IF Y'>0
SET PSJSTOP=1
QUIT
+46 SET PSJSELY=$GET(PCKSEL(+Y))
End DoDot:1
+47 ; Get sub-file pointers to drawer and pocket selected by user
+48 if $GET(PSJSTOP)
QUIT
+49 SET DRWIEN=$PIECE($GET(PSJSELY),"^",2)
+50 SET PCKIEN=$PIECE($GET(PSJSELY),"^",3)
+51 SET DRGDRW=$PIECE($GET(PSJSELY),"^",5)
+52 SET DRGDEV=$GET(DRWPCK(DRWPCK,"DRGDEV"))
+53 ; If the drug is not stocked in more than one pocket, set the device balance to zero so the UNLOAD removes it completely from device
+54 IF '(PCKCNT>1)
Begin DoDot:1
+55 SET DEVBAL=$PIECE($GET(^PS(58.601,+$GET(PSJPSYS),"DEVICE",+$GET(PADIEN),"DRUG",+$GET(DRGDEV),0)),"^",3)
+56 IF DEVBAL
SET $PIECE(^PS(58.601,+$GET(PSJPSYS),"DEVICE",+$GET(PADIEN),"DRUG",+$GET(DRGDEV),0),"^",3)=0
End DoDot:1
+57 DO UNLOAD(PSJPSYS,PADIEN,DRWIEN,DRGDRW,DRGDEV,PCKIEN)
+58 WRITE " ...Done."
+59 NEW DIR,X,Y
SET DIR(0)="Y"
+60 SET DIR("A")="Delete another drug"
+61 DO ^DIR
+62 IF '$GET(Y)
SET PSJSTOP=1
+63 QUIT
+64 ;
UNLHLP ; Display help text explaining PADE manual unload
+1 NEW HELPAR
+2 SET HELPAR(1)="This action removes one drug item from a specific pocket from this"
+3 SET HELPAR(2)="PADE dispensing device in VistA. Manually deleting a drug item does"
+4 SET HELPAR(3)="not affect the PADE vendor, and does not trigger any HL7 messages to"
+5 SET HELPAR(4)="the PADE vendor system. Manually deleting a drug item reduces the"
+6 SET HELPAR(5)="quantity of the drug that displays as available in VistA when running"
+7 SET HELPAR(6)="the PADE INVENTORY REPORT, and also removes the drug from balances"
+8 SET HELPAR(7)="displayed in Inpatient Order Entry."
+9 SET HELPAR(8)="After a drug is deleted, the drug may be added back to the cabinet's"
+10 SET HELPAR(9)="inventory as new HL7 messages are received from the vendor."
+11 DO EN^DDIOL(.HELPAR)
+12 QUIT
+13 ;
OLDPKUP(TMPADATA,ERRMSG,PS586IEN) ; Return 1 if data in TMPADATA indicates this pocket was updated more recently than the current transaction's date/time
+1 ; POCKET_SUBDRAWER concatenated
NEW POCKSUB
+2 ; The last transaction date/time (date/time of the activity at the cabinet) this pocket was updated
NEW PSPRVDT
+3 ; The IEN of the last transaction date/time in the "PKUPDT" multiple
NEW PSPRVDIE
+4 NEW FDA,PSJPSYS,PSJSCR,PSJSCR
+5 ;
+6 ;*356
KILL DIERR,ERR
SET TMPADATA("SYS IEN")=$$FIND1^DIC(58.601,"","MX",$GET(TMPADATA(1)),,,"ERR")
KILL DIERR
+7 IF '$GET(TMPADATA("SYS IEN"))
QUIT 0
+8 ;
+9 IF '($GET(TMPADATA(2))]"")
QUIT 0
+10 IF $GET(PSJPSYS)
IF $GET(^PS(58.601,+PSJPSYS,0))]""
SET TMPADATA("SYS IEN")=PSJPSYS
+11 SET PSJPSYS=TMPADATA("SYS IEN")
SET PSJSCR="I $S('$G(PSJPSYS):1,1:PSJPSYS=$P(^(0),U,2))"
+12 IF ($GET(TMPADATA(1))=""&$GET(PSJPSYS))
SET TMPADATA(1)=$PIECE(^PS(58.601,PSJPSYS,0),"^")
+13 ;*356
KILL ERR,DIERR
SET TMPADATA("DEVICE IEN")=$$FIND1^DIC(58.63,,"BX",TMPADATA(2),,PSJSCR,"ERR")
KILL DIERR
+14 if '$GET(TMPADATA("DEVICE IEN"))
QUIT 0
+15 SET TMPADATA("DEVICE IEN")=$ORDER(^PS(58.601,+$GET(TMPADATA("SYS IEN")),"DEVICE","B",TMPADATA("DEVICE IEN"),0))
+16 if '$GET(TMPADATA("DEVICE IEN"))
QUIT 0
+17 ;
+18 IF $GET(TMPADATA(3))=""
SET TMPADATA(3)="zz"
+19 SET TMPADATA("DRAWER IEN")=$ORDER(^PS(58.601,+$GET(TMPADATA("SYS IEN")),"DEVICE",+$GET(TMPADATA("DEVICE IEN")),"DRAWER","B",$GET(TMPADATA(3)),0))
+20 IF '$GET(TMPADATA("DRAWER IEN"))
QUIT 0
+21 ;
+22 NEW DRUG,DEVIEN,SYSIEN
+23 ; Drug
SET DRUG=$GET(TMPADATA(4))
+24 ; Dispensing Device IEN
SET DEVIEN=$GET(TMPADATA("DEVICE IEN"))
+25 ; PADE System IEN
SET SYSIEN=$GET(TMPADATA("SYS IEN"))
+26 ; No drug, no go
IF '(DRUG]"")
QUIT 0
+27 ; No valid drug
IF '$DATA(^PSDRUG(DRUG,0))
QUIT 0
+28 ; Must have PADE system and Dispensing Device
+29 IF '$GET(DEVIEN)
QUIT 0
+30 IF '$GET(SYSIEN)
QUIT 0
+31 ;
+32 NEW DA,FDA,X,Y,DIC,DIE,DR,D0,ERR,D,DD,DICR,DICRS,DO
+33 ;*356
SET TMPADATA("DRUG DEV IEN")=$$FIND1^DIC(58.60111,","_DEVIEN_","_SYSIEN_",","MXQ",DRUG,,,"ERR")
KILL DIERR
+34 ;
+35 ; Append subdrawer unique drug IEN suffix to handle different drugs in same subdr-pocket combo
SET TMPADATA(10)=$TRANSLATE(TMPADATA(10),"~~")_"~~"_+$GET(TMPADATA(4))
+36 if $GET(TMPADATA(10))=""
SET TMPADATA(10)=$PIECE($GET(^PS(58.6,+$GET(PS586IEN),0)),"^",12)
if TMPADATA(10)=""
SET TMPADATA(10)="~~"_+$GET(TMPADATA(4))
+37 ; "POCKET_SUBDRAWER" storage location
SET POCKSUB=$GET(TMPADATA(7))_"_"_$GET(TMPADATA(10))
+38 ;*356
KILL ERR,DIERR
SET TMPADATA("POCK/SUB IEN")=$$FIND1^DIC(58.601122,","_TMPADATA("DRAWER IEN")_","_TMPADATA("DEVICE IEN")_","_TMPADATA("SYS IEN")_",","MX",POCKSUB,,,"ERR")
KILL DIERR
+39 ; Get the last date/time this drawer/subdrawer~drug/pocket was updated
+40 SET PSPRVDIE=$ORDER(^PS(58.601,+$GET(TMPADATA("SYS IEN")),"DEVICE",+$GET(TMPADATA("DEVICE IEN")),"DRAWER",+$GET(TMPADATA("DRAWER IEN")),"PKUPDT","B",POCKSUB,""))
+41 ;
+42 SET PSPRVDT=$PIECE($GET(^PS(58.601,+$GET(TMPADATA("SYS IEN")),"DEVICE",+$GET(TMPADATA("DEVICE IEN")),"DRAWER",+$GET(TMPADATA("DRAWER IEN")),"PKUPDT",+$GET(PSPRVDIE),0)),"^",2)
+43 ; If this current update contains a transaction date/time (i.e., activity date/time) older than the last update, don't update inventory
+44 IF $GET(PSPRVDT)&$GET(TMPADATA(9))
IF TMPADATA(9)<PSPRVDT
Begin DoDot:1
+45 SET ERRMSG="- OUTDATED TRANSACTION - "_$GET(TMPADATA(1))_"."_$GET(TMPADATA(2))_".DRUG="_$PIECE($GET(^PSDRUG(+$GET(TMPADATA(4)),0)),"^")_"("_$GET(TMPADATA(4))_").POCKET="_$GET(TMPADATA(7))
+46 SET ERRMSG=ERRMSG_".LAST UPDATED="_PSPRVDT_".TRANS DT="_TMPADATA(9)
End DoDot:1
QUIT 1
+47 QUIT 0
