Routine: PSJPAD70

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.

DWO(PSJOMS) ; Send Dispensed Without Order (DWO) Alert

 N GROUPS

 S GROUPS=""

 Q:'$$ACTDWO(.PSJOMS)

 D GETGRPS(.PSJOMS,.GROUPS)

 D DWOSEND(.PSJOMS,.GROUPS)

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)

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

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

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)

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

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)

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  Feb 18, 2025@23:34:55                                                                                                                                                                                                   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

PSJPAD70.m