PSJPADPT ;BIR/JCH - PADE Activity Utility ;09/22/11 5:00pm
;;5.0;INPATIENT MEDICATIONS;**317**;16 DEC 97;Build 130
;
; References to ^PSSDSAPM is supported by DBIA 5570.
; Reference to FULL^VALM1 is supported by DBIA 10116.
; Reference to $$FMTE^XLFDT is supported by DBIA 10103.
; Reference to ^PSDRUG is supported by DBIA 2192.
;
PADECK ;
N PSJTCNT,PSJTSCR
K VALMBCK
S PSJPADPT=1,PSJTSCR=15
D FULL^VALM1
I '$$ACTIVITY(DFN,PSJTSCR) D
.W !!,"No PADE activity on file",!
.K DIR S DIR(0)="EAO",DIR("A")="Press Return to Continue..." D ^DIR K DIR W @IOF
.W @IOF
PADEND S VALMBCK="R"
K PSJPADPT
Q
;
ACTIVITY(DFN,PSJTSCR) ; Get PADE activity for patient DFN, display to screen length PSJTSCR
N PSPDT,PSPDRG,PSTRANS,PSJPOP,PSJCONT,PSJPAGE,PSJPGTMP
K DIR W @IOF
S (PSJTCNT,PSJPOP,PSJPAGE)=0
S PSPDT=99999999 F S PSPDT=$O(^PS(58.6,"P",+$G(DFN),PSPDT),-1) Q:'PSPDT!PSJPOP D
.S PSPDRG="" F S PSPDRG=$O(^PS(58.6,"P",+$G(DFN),PSPDT,PSPDRG)) Q:(PSPDRG="")!PSJPOP D
..S PSTRANS=0 F S PSTRANS=$O(^PS(58.6,"P",+$G(DFN),PSPDT,PSPDRG,PSTRANS)) Q:'PSTRANS!PSJPOP D
...S PSJCONT=$G(PSJCONT)+1
...I 'PSJTCNT D PGHEAD
...N PSEXDT,PSEXTM,PSEXDRG,PSJCAB,PSJQTY,PSJSTS,PSJORD,ND0,ND1,ND2,PSEXDRG2,PSJOVOK,PSJQAR
...S ND0=$G(^PS(58.6,PSTRANS,0)),ND1=$G(^PS(58.6,PSTRANS,1))
...S PSEXDT=$$PSEXDT(PSPDT)
...S PSEXDRG=$S($G(PSPDRG):$P($G(^PSDRUG(+PSPDRG,0)),"^"),1:$P(PSPDRG,"zz",2))
...I PSPDRG="zz~UNKNOWN" S PSEXDRG2=$P(ND1,"^",6) I PSEXDRG2]"" S PSEXDRG=PSEXDRG2
...S:$L(PSEXDRG)>36 PSEXDRG=$E(PSEXDRG,1,36)_"_"
...S PSJORD=$P(ND1,"^")
...S PSJQTY=$P(ND0,"^",4) I PSJQTY["." N PSJDEC S PSJDEC="."_$E($P(PSJQTY,".",2),1,2) D
....I 'PSJDEC!(PSJDEC=".") S PSJQTY=$P(PSJQTY,".") Q ; insignificant trailing zeroes
....S PSJQTY=$P(PSJQTY,".")_+PSJDEC
...S PSJCAB=$P(ND0,"^",2)
...S PSJSTS=$P(ND0,"^",5)
...S PSJQAR(5)=PSJSTS,PSJQAR(6)=PSJQTY N PSJSIGN S PSJSIGN=$$TSIGN^PSJPADIT(.PSJQAR) S:PSJQTY["-" PSJQTY=$P(PSJQTY,"-",2) S PSJQTY=PSJSIGN_PSJQTY
...S PSJOVOK=$S(PSJSTS="V":1,PSJSTS="R":1,PSJSTS="W":1,1:0)
...S PSJSTS=$S(PSJSTS="V":"DISP",PSJSTS="R":"RTN",PSJSTS="W":"WASTE",PSJSTS="D":"DESTK",PSJSTS="L":"LOAD",PSJSTS="U":"UNLD",PSJSTS="F":"FILL",PSJSTS="N":"CANCL",PSJSTS="C":"COUNT",PSJSTS="E":"EXP",PSJSTS="A":"DISCR",1:PSJSTS)
...S:$E(PSJSTS)="W" PSJQTY="NA"
...W !,PSEXDT S PSJTCNT=$G(PSJTCNT)+1
...W ?15,$S(PSJORD:"N",'PSJOVOK:"",1:"Y"),?18,$E(PSEXDRG,1,39),?56,$E(PSJSTS,1,6),?62,$J(PSJQTY,3),?69,PSJCAB
...S ND2=$P($G(^PS(58.6,PSTRANS,2)),"^") I ND2]"" W !," Comment: ",$E(ND2,1,66) S PSJTCNT=$G(PSJTCNT)+1
...I (PSJTCNT\PSJTSCR)>PSJPAGE D CONTINUE(.PSJPAGE)
...S PSJPGTMP=PSJPAGE
I $G(PSJCONT) D CONTINUE(.PSJPAGE)
K DIR W @IOF
Q PSJTCNT
;
PGHEAD ; Print Page Header
W !,"Pharmacy Automated Dispensing Equipment (PADE) Activity Log"
D COHEAD
Q
;
COHEAD ; Print Column Header
W @IOF
W !!,"Date/Time",?14,"O-R",?18,"Item",?55,"Status",?63,"Qty",?69,"PADE ID"
W !,"================================================================================"
Q
;
CONTINUE(PSJPAGE) ; Press return to continue
N X,DIR
S DIR("A",1)=" "
S DIR(0)="EAO",DIR("A")="Press Return to Continue..." D ^DIR S:$G(X)="^" PSJPOP=1
K DIR
D COHEAD
S PSJPAGE=$G(PSJPAGE)+1
K PSJCONT
Q
;
PSEXDT(DT) ; Format Date for display
N XDT,XTM,I
S XDT=$P($TR($$FMTE^XLFDT(DT,2),"@"," "),":",1,2)
S XTM=$P(XDT," ",2)
F I=1:1:3 S $P(XDT,"/",I)=$TR($J(+$P(XDT,"/",I),2)," ",0)
S XDT=XDT_" "_XTM
Q XDT
;
ASKRESET(PADE) ; Prompt to reset PADE device balances
N DIR,X,Y
S DIR(0)="Y",DIR("A")="RESET/INITIALIZE PADE DEVICE"
S DIR("?")="^D RESHLP^PSJPADPT"
S DIR("B")="N" D ^DIR
I 'Y D MANUN^PSJPAD70(PADE) Q
Q:'$$SURES()
D CONTRES(PADE)
Q
;
SURES() ; Ask user if they're really sure about deleting all meds from device
N DIR,X,Y
S DIR(0)="Y"
S DIR("A",1)=" "
S DIR("A",2)=" CAUTION: THIS WILL DELETE THE LIST OF MEDICATIONS"
S DIR("A",3)=" LINKED TO THIS PADE CABINET (in VistA only)."
S DIR("A",4)=" "
S DIR("A")="Are you sure you want to do this",DIR("B")="N"
S DIR("?")="^D RESHLP^PSJPADPT"
D ^DIR
Q Y
;
CONTRES(PADE) ; Finish device reset
N FDA,PSPADER
I '$$RESPADE(PADE) W " ...Unable to reset "_$G(PADE) Q
S FDA(58.639,"?+1,"_+PADE_",",.01)=$$NOW^XLFDT()
D UPDATE^DIE("","FDA","PSPADER")
I $G(PSPADER(1,0))="+" W " ...PADE initialization complete."
Q
;
RESPADE(PADE) ; Reset balances in PADE cabinet to zero
N DRUG,DRAWER,POCKET,SUBPCK,PSJPSYS,DIK,DA,PADIEN,PADENAM,PSPADER,PSJY
D GETS^DIQ(58.63,PADE_",",1,"I","PSJPSYS")
S PSJPSYS=$G(PSJPSYS("58.63",+PADE_",",1,"I"))
Q:'$G(PSJPSYS)!'$D(^PS(58.601,+$G(PSJPSYS),0)) 0
S PADENAM=$P($G(^PS(58.63,+PADE,0)),"^")
S PADIEN=$$FIND1^DIC(58.6011,","_PSJPSYS_",","MX",PADENAM,,,"PSPADER")
Q:'$G(PADIEN)!'$G(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,0)) 0
S DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRAWER"","
S DA(2)=+PSJPSYS,DA(1)=+PADIEN
S DRAWER=0 F S DRAWER=$O(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRAWER",DRAWER)) Q:'DRAWER D
.S DA=DRAWER D ^DIK
S DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRUG"","
S DA(2)=+PSJPSYS,DA(1)=+PADIEN
S DRUG=0 F S DRUG=$O(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRUG",DRUG)) Q:'DRUG D
.S DA=DRUG D ^DIK
Q 1
;
EMPTY(PADE) ; Return 1 if PADE cabinet contains no drugs
; INPUT : PADE - Pointer to PADE DISPENSING DEVICE (#58.63) FILE
N EMPTY
S EMPTY=0
I '$D(^PS(58.601,"DEV",+PADE)) S EMPTY=1
Q EMPTY
;
RESHLP ; Display help text explaining PADE reset
N HELPAR
S HELPAR(1)="This action deletes all medications from this PADE cabinet in VistA,"
S HELPAR(2)="making the cabinet appear empty to VistA users. This does not affect"
S HELPAR(3)="the vendor system. Resetting a cabinet makes the device unavailable"
S HELPAR(4)="to the PADE INVENTORY REPORT as it will no longer have inventory."
S HELPAR(5)="After a PADE cabinet is reset, medications will be added babck to the"
S HELPAR(6)="cabinet as new HL7 messages are received from the vendor, and the"
S HELPAR(7)="cabinet will be available again for reports and order entry lookups."
D EN^DDIOL(.HELPAR)
Q
;
PARTIAL(PSJY,INARRAY,OUTARRAY,DISPDATA,MSG,ARRAYX,FOUND,NOXREF,PSALLPC) ; Lookup PSJY in INARRAY
; INPUT - PSJY=Lookup text
; - INARRAY(text)=number - Array of selectable data
; OUTPUT - OUTARRAY(text)=number - Entry selected from INARRAY
;
N PSJPART,ITMNAME,II,ITM,ITMX,Y,PSJTMP,PSJDUP
K FOUND
S II=1,ITMID="" F S ITMID=$O(INARRAY(ITMID)) Q:ITMID="" D
.Q:ITMID="IEN"!(ITMID="NAME")
.S ITM(ITMID)=$P(INARRAY(ITMID),"^"),ITMX(INARRAY(ITMID),ITMID)=$P(INARRAY(ITMID),"^",2)
;
Q:$D(ITM)<10
F ITM="" F S ITM=$O(ITM(ITM)) Q:ITM="" D
.S PSJDUP=0
.I $E(ITM,1,$L(PSJY))=PSJY D Q:'$G(PSJDUP)
..N PP,QQ S PP="" F S PP=$O(PSJPART(PP)) Q:PP="" S QQ="" F S QQ=$O(PSJPART(PP,QQ)) Q:QQ="" I PSJPART(PP,QQ)=ITM(ITM) S PSJDUP=1
..Q:$G(PSJDUP)
..S PSJPART(II,ITM)=INARRAY(ITM)
..S PSJPART(II,ITM)=PSJPART(II,ITM)_"^"_$P($G(ARRAYX(ITM(ITM))),"^",2)
..S II=II+1
.I '$G(NOXREF) I $E(ITM(ITM),1,$L(PSJY))=PSJY D Q:'$G(PSJDUP)
..N PP,QQ S PP="" F S PP=$O(PSJPART(PP)) Q:PP="" S QQ="" F S QQ=$O(PSJPART(PP,QQ)) Q:QQ="" I PSJPART(PP,QQ)=ITM(ITM) S PSJDUP=1
..Q:$G(PSJDUP)
..S PSJPART(II,ITM)=ITM(ITM)
..S PSJPART(II,ITM)=PSJPART(II,ITM)_"^"_$P($G(ARRAYX(ITM(ITM))),"^",2)
..S II=II+1
.I $$UPPER^HLFNC($E(ITM,1,$L(PSJY)))=$$UPPER^HLFNC(PSJY) D Q:'$G(PSJDUP)
..N PP,QQ S PP="" F S PP=$O(PSJPART(PP)) Q:PP="" S QQ="" F S QQ=$O(PSJPART(PP,QQ)) Q:QQ="" I PSJPART(PP,QQ)=ITM(ITM) S PSJDUP=1
..Q:$G(PSJDUP)
..S PSJPART(II,ITM)=INARRAY(ITM)_"^"_$P($G(ARRAYX(ITM(ITM))),"^",2)
..S II=II+1
.I '$G(NOXREF) I $$UPPER^HLFNC($E(ITM(ITM),1,$L(PSJY)))=$$UPPER^HLFNC(PSJY) D Q:'$G(PSJDUP)
..N PP,QQ S PP="" F S PP=$O(PSJPART(PP)) Q:PP="" S QQ="" F S QQ=$O(PSJPART(PP,QQ)) Q:QQ="" I PSJPART(PP,QQ)=ITM(ITM) S PSJDUP=1
..Q:$G(PSJDUP)
..S PSJPART(II,ITM)=ITM(ITM)_"^"_$P($G(ARRAYX(ITM(ITM))),"^",2)
..S II=II+1
I $D(PSJPART(1)) D
.N DIR,STRING,CNT
.I '$O(PSJPART(1)) S PSJTMP=$O(PSJPART(1,"")) D Q
..S OUTARRAY(PSJTMP)=$S('$G(PSALLPC):$P(PSJPART(1,PSJTMP),"^"),1:PSJPART(1,PSJTMP)),FOUND=1
..W !," "_$O(PSJPART(1,"")),?15,$P(PSJPART(1,PSJTMP),"^")
.I $L($G(MSG)) W !,MSG,!
.S CNT=0 F S CNT=$O(PSJPART(CNT)) Q:'CNT D
..N ITMID S ITMID=$O(PSJPART(CNT,""))
..S STRING=$G(STRING)_CNT_":"_ITMID_";"
..S DIR("A",CNT)=" "_CNT_" "_ITMID_$S($G(DISPDATA):" "_$P($G(PSJPART(CNT,ITMID)),"^"),1:"")
.S DIR("A")="Choose 1-"_+$O(PSJPART(9999999),-1)_": "
.S DIR(0)="SAO^"_STRING D ^DIR
.I Y>0 D Q
..N PSPTSEL S PSPTSEL=$O(PSJPART(+Y,""))
..S OUTARRAY(PSPTSEL)=$S('$G(PSALLPC):$P(PSJPART(+Y,PSPTSEL),"^"),1:$G(PSJPART(+Y,PSPTSEL))),FOUND=1
..N ID2 S ID2=$G(OUTARRAY(PSPTSEL)) I ID2]"" W " ",$P(ID2,"^")
.S PSJY=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPADPT 8912 printed Jan 18, 2025@03:09:51 Page 2
PSJPADPT ;BIR/JCH - PADE Activity Utility ;09/22/11 5:00pm
+1 ;;5.0;INPATIENT MEDICATIONS;**317**;16 DEC 97;Build 130
+2 ;
+3 ; References to ^PSSDSAPM is supported by DBIA 5570.
+4 ; Reference to FULL^VALM1 is supported by DBIA 10116.
+5 ; Reference to $$FMTE^XLFDT is supported by DBIA 10103.
+6 ; Reference to ^PSDRUG is supported by DBIA 2192.
+7 ;
PADECK ;
+1 NEW PSJTCNT,PSJTSCR
+2 KILL VALMBCK
+3 SET PSJPADPT=1
SET PSJTSCR=15
+4 DO FULL^VALM1
+5 IF '$$ACTIVITY(DFN,PSJTSCR)
Begin DoDot:1
+6 WRITE !!,"No PADE activity on file",!
+7 KILL DIR
SET DIR(0)="EAO"
SET DIR("A")="Press Return to Continue..."
DO ^DIR
KILL DIR
WRITE @IOF
+8 WRITE @IOF
End DoDot:1
PADEND SET VALMBCK="R"
+1 KILL PSJPADPT
+2 QUIT
+3 ;
ACTIVITY(DFN,PSJTSCR) ; Get PADE activity for patient DFN, display to screen length PSJTSCR
+1 NEW PSPDT,PSPDRG,PSTRANS,PSJPOP,PSJCONT,PSJPAGE,PSJPGTMP
+2 KILL DIR
WRITE @IOF
+3 SET (PSJTCNT,PSJPOP,PSJPAGE)=0
+4 SET PSPDT=99999999
FOR
SET PSPDT=$ORDER(^PS(58.6,"P",+$GET(DFN),PSPDT),-1)
if 'PSPDT!PSJPOP
QUIT
Begin DoDot:1
+5 SET PSPDRG=""
FOR
SET PSPDRG=$ORDER(^PS(58.6,"P",+$GET(DFN),PSPDT,PSPDRG))
if (PSPDRG="")!PSJPOP
QUIT
Begin DoDot:2
+6 SET PSTRANS=0
FOR
SET PSTRANS=$ORDER(^PS(58.6,"P",+$GET(DFN),PSPDT,PSPDRG,PSTRANS))
if 'PSTRANS!PSJPOP
QUIT
Begin DoDot:3
+7 SET PSJCONT=$GET(PSJCONT)+1
+8 IF 'PSJTCNT
DO PGHEAD
+9 NEW PSEXDT,PSEXTM,PSEXDRG,PSJCAB,PSJQTY,PSJSTS,PSJORD,ND0,ND1,ND2,PSEXDRG2,PSJOVOK,PSJQAR
+10 SET ND0=$GET(^PS(58.6,PSTRANS,0))
SET ND1=$GET(^PS(58.6,PSTRANS,1))
+11 SET PSEXDT=$$PSEXDT(PSPDT)
+12 SET PSEXDRG=$SELECT($GET(PSPDRG):$PIECE($GET(^PSDRUG(+PSPDRG,0)),"^"),1:$PIECE(PSPDRG,"zz",2))
+13 IF PSPDRG="zz~UNKNOWN"
SET PSEXDRG2=$PIECE(ND1,"^",6)
IF PSEXDRG2]""
SET PSEXDRG=PSEXDRG2
+14 if $LENGTH(PSEXDRG)>36
SET PSEXDRG=$EXTRACT(PSEXDRG,1,36)_"_"
+15 SET PSJORD=$PIECE(ND1,"^")
+16 SET PSJQTY=$PIECE(ND0,"^",4)
IF PSJQTY["."
NEW PSJDEC
SET PSJDEC="."_$EXTRACT($PIECE(PSJQTY,".",2),1,2)
Begin DoDot:4
+17 ; insignificant trailing zeroes
IF 'PSJDEC!(PSJDEC=".")
SET PSJQTY=$PIECE(PSJQTY,".")
QUIT
+18 SET PSJQTY=$PIECE(PSJQTY,".")_+PSJDEC
End DoDot:4
+19 SET PSJCAB=$PIECE(ND0,"^",2)
+20 SET PSJSTS=$PIECE(ND0,"^",5)
+21 SET PSJQAR(5)=PSJSTS
SET PSJQAR(6)=PSJQTY
NEW PSJSIGN
SET PSJSIGN=$$TSIGN^PSJPADIT(.PSJQAR)
if PSJQTY["-"
SET PSJQTY=$PIECE(PSJQTY,"-",2)
SET PSJQTY=PSJSIGN_PSJQTY
+22 SET PSJOVOK=$SELECT(PSJSTS="V":1,PSJSTS="R":1,PSJSTS="W":1,1:0)
+23 SET PSJSTS=$SELECT(PSJSTS="V":"DISP",PSJSTS="R":"RTN",PSJSTS="W":"WASTE",PSJSTS="D":"DESTK",PSJSTS="L":"LOAD",PSJSTS="U":"UNLD",PSJSTS="F":"FILL",PSJSTS="N":"CANCL",PSJSTS="C":"COUNT",PSJSTS="E":"EXP",PSJSTS="A":"DISCR",
1:PSJSTS)
+24 if $EXTRACT(PSJSTS)="W"
SET PSJQTY="NA"
+25 WRITE !,PSEXDT
SET PSJTCNT=$GET(PSJTCNT)+1
+26 WRITE ?15,$SELECT(PSJORD:"N",'PSJOVOK:"",1:"Y"),?18,$EXTRACT(PSEXDRG,1,39),?56,$EXTRACT(PSJSTS,1,6),?62,$JUSTIFY(PSJQTY,3),?69,PSJCAB
+27 SET ND2=$PIECE($GET(^PS(58.6,PSTRANS,2)),"^")
IF ND2]""
WRITE !," Comment: ",$EXTRACT(ND2,1,66)
SET PSJTCNT=$GET(PSJTCNT)+1
+28 IF (PSJTCNT\PSJTSCR)>PSJPAGE
DO CONTINUE(.PSJPAGE)
+29 SET PSJPGTMP=PSJPAGE
End DoDot:3
End DoDot:2
End DoDot:1
+30 IF $GET(PSJCONT)
DO CONTINUE(.PSJPAGE)
+31 KILL DIR
WRITE @IOF
+32 QUIT PSJTCNT
+33 ;
PGHEAD ; Print Page Header
+1 WRITE !,"Pharmacy Automated Dispensing Equipment (PADE) Activity Log"
+2 DO COHEAD
+3 QUIT
+4 ;
COHEAD ; Print Column Header
+1 WRITE @IOF
+2 WRITE !!,"Date/Time",?14,"O-R",?18,"Item",?55,"Status",?63,"Qty",?69,"PADE ID"
+3 WRITE !,"================================================================================"
+4 QUIT
+5 ;
CONTINUE(PSJPAGE) ; Press return to continue
+1 NEW X,DIR
+2 SET DIR("A",1)=" "
+3 SET DIR(0)="EAO"
SET DIR("A")="Press Return to Continue..."
DO ^DIR
if $GET(X)="^"
SET PSJPOP=1
+4 KILL DIR
+5 DO COHEAD
+6 SET PSJPAGE=$GET(PSJPAGE)+1
+7 KILL PSJCONT
+8 QUIT
+9 ;
PSEXDT(DT) ; Format Date for display
+1 NEW XDT,XTM,I
+2 SET XDT=$PIECE($TRANSLATE($$FMTE^XLFDT(DT,2),"@"," "),":",1,2)
+3 SET XTM=$PIECE(XDT," ",2)
+4 FOR I=1:1:3
SET $PIECE(XDT,"/",I)=$TRANSLATE($JUSTIFY(+$PIECE(XDT,"/",I),2)," ",0)
+5 SET XDT=XDT_" "_XTM
+6 QUIT XDT
+7 ;
ASKRESET(PADE) ; Prompt to reset PADE device balances
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="RESET/INITIALIZE PADE DEVICE"
+3 SET DIR("?")="^D RESHLP^PSJPADPT"
+4 SET DIR("B")="N"
DO ^DIR
+5 IF 'Y
DO MANUN^PSJPAD70(PADE)
QUIT
+6 if '$$SURES()
QUIT
+7 DO CONTRES(PADE)
+8 QUIT
+9 ;
SURES() ; Ask user if they're really sure about deleting all meds from device
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
+3 SET DIR("A",1)=" "
+4 SET DIR("A",2)=" CAUTION: THIS WILL DELETE THE LIST OF MEDICATIONS"
+5 SET DIR("A",3)=" LINKED TO THIS PADE CABINET (in VistA only)."
+6 SET DIR("A",4)=" "
+7 SET DIR("A")="Are you sure you want to do this"
SET DIR("B")="N"
+8 SET DIR("?")="^D RESHLP^PSJPADPT"
+9 DO ^DIR
+10 QUIT Y
+11 ;
CONTRES(PADE) ; Finish device reset
+1 NEW FDA,PSPADER
+2 IF '$$RESPADE(PADE)
WRITE " ...Unable to reset "_$GET(PADE)
QUIT
+3 SET FDA(58.639,"?+1,"_+PADE_",",.01)=$$NOW^XLFDT()
+4 DO UPDATE^DIE("","FDA","PSPADER")
+5 IF $GET(PSPADER(1,0))="+"
WRITE " ...PADE initialization complete."
+6 QUIT
+7 ;
RESPADE(PADE) ; Reset balances in PADE cabinet to zero
+1 NEW DRUG,DRAWER,POCKET,SUBPCK,PSJPSYS,DIK,DA,PADIEN,PADENAM,PSPADER,PSJY
+2 DO GETS^DIQ(58.63,PADE_",",1,"I","PSJPSYS")
+3 SET PSJPSYS=$GET(PSJPSYS("58.63",+PADE_",",1,"I"))
+4 if '$GET(PSJPSYS)!'$DATA(^PS(58.601,+$GET(PSJPSYS),0))
QUIT 0
+5 SET PADENAM=$PIECE($GET(^PS(58.63,+PADE,0)),"^")
+6 SET PADIEN=$$FIND1^DIC(58.6011,","_PSJPSYS_",","MX",PADENAM,,,"PSPADER")
+7 if '$GET(PADIEN)!'$GET(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,0))
QUIT 0
+8 SET DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRAWER"","
+9 SET DA(2)=+PSJPSYS
SET DA(1)=+PADIEN
+10 SET DRAWER=0
FOR
SET DRAWER=$ORDER(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRAWER",DRAWER))
if 'DRAWER
QUIT
Begin DoDot:1
+11 SET DA=DRAWER
DO ^DIK
End DoDot:1
+12 SET DIK="^PS(58.601,"_+PSJPSYS_",""DEVICE"","_+PADIEN_",""DRUG"","
+13 SET DA(2)=+PSJPSYS
SET DA(1)=+PADIEN
+14 SET DRUG=0
FOR
SET DRUG=$ORDER(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRUG",DRUG))
if 'DRUG
QUIT
Begin DoDot:1
+15 SET DA=DRUG
DO ^DIK
End DoDot:1
+16 QUIT 1
+17 ;
EMPTY(PADE) ; Return 1 if PADE cabinet contains no drugs
+1 ; INPUT : PADE - Pointer to PADE DISPENSING DEVICE (#58.63) FILE
+2 NEW EMPTY
+3 SET EMPTY=0
+4 IF '$DATA(^PS(58.601,"DEV",+PADE))
SET EMPTY=1
+5 QUIT EMPTY
+6 ;
RESHLP ; Display help text explaining PADE reset
+1 NEW HELPAR
+2 SET HELPAR(1)="This action deletes all medications from this PADE cabinet in VistA,"
+3 SET HELPAR(2)="making the cabinet appear empty to VistA users. This does not affect"
+4 SET HELPAR(3)="the vendor system. Resetting a cabinet makes the device unavailable"
+5 SET HELPAR(4)="to the PADE INVENTORY REPORT as it will no longer have inventory."
+6 SET HELPAR(5)="After a PADE cabinet is reset, medications will be added babck to the"
+7 SET HELPAR(6)="cabinet as new HL7 messages are received from the vendor, and the"
+8 SET HELPAR(7)="cabinet will be available again for reports and order entry lookups."
+9 DO EN^DDIOL(.HELPAR)
+10 QUIT
+11 ;
PARTIAL(PSJY,INARRAY,OUTARRAY,DISPDATA,MSG,ARRAYX,FOUND,NOXREF,PSALLPC) ; Lookup PSJY in INARRAY
+1 ; INPUT - PSJY=Lookup text
+2 ; - INARRAY(text)=number - Array of selectable data
+3 ; OUTPUT - OUTARRAY(text)=number - Entry selected from INARRAY
+4 ;
+5 NEW PSJPART,ITMNAME,II,ITM,ITMX,Y,PSJTMP,PSJDUP
+6 KILL FOUND
+7 SET II=1
SET ITMID=""
FOR
SET ITMID=$ORDER(INARRAY(ITMID))
if ITMID=""
QUIT
Begin DoDot:1
+8 if ITMID="IEN"!(ITMID="NAME")
QUIT
+9 SET ITM(ITMID)=$PIECE(INARRAY(ITMID),"^")
SET ITMX(INARRAY(ITMID),ITMID)=$PIECE(INARRAY(ITMID),"^",2)
End DoDot:1
+10 ;
+11 if $DATA(ITM)<10
QUIT
+12 FOR ITM=""
FOR
SET ITM=$ORDER(ITM(ITM))
if ITM=""
QUIT
Begin DoDot:1
+13 SET PSJDUP=0
+14 IF $EXTRACT(ITM,1,$LENGTH(PSJY))=PSJY
Begin DoDot:2
+15 NEW PP,QQ
SET PP=""
FOR
SET PP=$ORDER(PSJPART(PP))
if PP=""
QUIT
SET QQ=""
FOR
SET QQ=$ORDER(PSJPART(PP,QQ))
if QQ=""
QUIT
IF PSJPART(PP,QQ)=ITM(ITM)
SET PSJDUP=1
+16 if $GET(PSJDUP)
QUIT
+17 SET PSJPART(II,ITM)=INARRAY(ITM)
+18 SET PSJPART(II,ITM)=PSJPART(II,ITM)_"^"_$PIECE($GET(ARRAYX(ITM(ITM))),"^",2)
+19 SET II=II+1
End DoDot:2
if '$GET(PSJDUP)
QUIT
+20 IF '$GET(NOXREF)
IF $EXTRACT(ITM(ITM),1,$LENGTH(PSJY))=PSJY
Begin DoDot:2
+21 NEW PP,QQ
SET PP=""
FOR
SET PP=$ORDER(PSJPART(PP))
if PP=""
QUIT
SET QQ=""
FOR
SET QQ=$ORDER(PSJPART(PP,QQ))
if QQ=""
QUIT
IF PSJPART(PP,QQ)=ITM(ITM)
SET PSJDUP=1
+22 if $GET(PSJDUP)
QUIT
+23 SET PSJPART(II,ITM)=ITM(ITM)
+24 SET PSJPART(II,ITM)=PSJPART(II,ITM)_"^"_$PIECE($GET(ARRAYX(ITM(ITM))),"^",2)
+25 SET II=II+1
End DoDot:2
if '$GET(PSJDUP)
QUIT
+26 IF $$UPPER^HLFNC($EXTRACT(ITM,1,$LENGTH(PSJY)))=$$UPPER^HLFNC(PSJY)
Begin DoDot:2
+27 NEW PP,QQ
SET PP=""
FOR
SET PP=$ORDER(PSJPART(PP))
if PP=""
QUIT
SET QQ=""
FOR
SET QQ=$ORDER(PSJPART(PP,QQ))
if QQ=""
QUIT
IF PSJPART(PP,QQ)=ITM(ITM)
SET PSJDUP=1
+28 if $GET(PSJDUP)
QUIT
+29 SET PSJPART(II,ITM)=INARRAY(ITM)_"^"_$PIECE($GET(ARRAYX(ITM(ITM))),"^",2)
+30 SET II=II+1
End DoDot:2
if '$GET(PSJDUP)
QUIT
+31 IF '$GET(NOXREF)
IF $$UPPER^HLFNC($EXTRACT(ITM(ITM),1,$LENGTH(PSJY)))=$$UPPER^HLFNC(PSJY)
Begin DoDot:2
+32 NEW PP,QQ
SET PP=""
FOR
SET PP=$ORDER(PSJPART(PP))
if PP=""
QUIT
SET QQ=""
FOR
SET QQ=$ORDER(PSJPART(PP,QQ))
if QQ=""
QUIT
IF PSJPART(PP,QQ)=ITM(ITM)
SET PSJDUP=1
+33 if $GET(PSJDUP)
QUIT
+34 SET PSJPART(II,ITM)=ITM(ITM)_"^"_$PIECE($GET(ARRAYX(ITM(ITM))),"^",2)
+35 SET II=II+1
End DoDot:2
if '$GET(PSJDUP)
QUIT
End DoDot:1
+36 IF $DATA(PSJPART(1))
Begin DoDot:1
+37 NEW DIR,STRING,CNT
+38 IF '$ORDER(PSJPART(1))
SET PSJTMP=$ORDER(PSJPART(1,""))
Begin DoDot:2
+39 SET OUTARRAY(PSJTMP)=$SELECT('$GET(PSALLPC):$PIECE(PSJPART(1,PSJTMP),"^"),1:PSJPART(1,PSJTMP))
SET FOUND=1
+40 WRITE !," "_$ORDER(PSJPART(1,"")),?15,$PIECE(PSJPART(1,PSJTMP),"^")
End DoDot:2
QUIT
+41 IF $LENGTH($GET(MSG))
WRITE !,MSG,!
+42 SET CNT=0
FOR
SET CNT=$ORDER(PSJPART(CNT))
if 'CNT
QUIT
Begin DoDot:2
+43 NEW ITMID
SET ITMID=$ORDER(PSJPART(CNT,""))
+44 SET STRING=$GET(STRING)_CNT_":"_ITMID_";"
+45 SET DIR("A",CNT)=" "_CNT_" "_ITMID_$SELECT($GET(DISPDATA):" "_$PIECE($GET(PSJPART(CNT,ITMID)),"^"),1:"")
End DoDot:2
+46 SET DIR("A")="Choose 1-"_+$ORDER(PSJPART(9999999),-1)_": "
+47 SET DIR(0)="SAO^"_STRING
DO ^DIR
+48 IF Y>0
Begin DoDot:2
+49 NEW PSPTSEL
SET PSPTSEL=$ORDER(PSJPART(+Y,""))
+50 SET OUTARRAY(PSPTSEL)=$SELECT('$GET(PSALLPC):$PIECE(PSJPART(+Y,PSPTSEL),"^"),1:$GET(PSJPART(+Y,PSPTSEL)))
SET FOUND=1
+51 NEW ID2
SET ID2=$GET(OUTARRAY(PSPTSEL))
IF ID2]""
WRITE " ",$PIECE(ID2,"^")
End DoDot:2
QUIT
+52 SET PSJY=""
End DoDot:1
+53 QUIT
