PSARDCUT ;BIRM/MFR - Return Drug - Utilities ;07/01/08
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**69,72**;10/24/97;Build 2
;References to DRUG file (#50) supported by IA #2095
;References to ^PSSNDCUT supported by IA #4707
;
PHLOC() ;Select Pharmacy location
N PSALOC,PSACNT,PSAOSIT,PSAOSITN,PSACOMB,PSAISIT,PSAISITN,PSALOCA
N PSALOCN,PSAMENU,DIR,X,Y
S PSALOC=+$O(^PSD(58.8,"ADISP","P",0)) I 'PSALOC D Q ""
.W !!?5,"No Drug Accountability location has been created yet."
;
;If more than one pharmacy location, collect them in alpha order.
S (PSACNT,PSALOC)=0
F S PSALOC=+$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:'PSALOC D
.Q:'$D(^PSD(58.8,PSALOC,0))!($P($G(^PSD(58.8,PSALOC,0)),"^")="")
.I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
.Q:'$O(^PSD(58.8,PSALOC,1,0))
.S (PSAOSIT,PSAOSITN)=""
.D SITES^PSAUTL1
.S PSALOCA($P(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=PSALOC_"^"_$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",10)_"^"_$P($G(^PSD(58.8,PSALOC,"I")),"^")
I $O(PSALOCA(""))="" Q ""
S PSALOCN="" F S PSALOCN=$O(PSALOCA(PSALOCN)) Q:PSALOCN="" D
.S PSALOC=0 F S PSALOC=$O(PSALOCA(PSALOCN,PSALOC)) Q:'PSALOC D
..S PSACNT=PSACNT+1,DIR("A",PSACNT)=PSACNT_". "_PSALOCN
..S PSAMENU(PSACNT,PSALOCN,PSALOC)=""
S DIR("A",PSACNT+1)=""
W !,"Choose one pharmacy location:",!
S DIR(0)="NO^1:"_PSACNT,DIR("A")="Select PHARMACY LOCATION"
S DIR("?")="Enter the number representing the Pharmacy Location"
D ^DIR
S PSALOCN=$O(PSAMENU(+Y,"")),PSALOC=$S(PSALOCN'="":+$O(PSAMENU(+Y,PSALOCN,0)),1:0)
Q $S(+PSALOC>0:PSALOCA(PSALOCN,PSALOC),1:"")
;
DTTM(DATE,SEC) ; Converts FM to MM/DD/YY@HHMM(SS) (w/ or /out seconds)
;
Q $P($$FMTE^XLFDT(DATE,"2Z"),":",1,$S($G(SEC):3,1:2))
;
LOGACT(PHLOC,BATCH,ITEM,TYPE,COMM) ; - Log an EDIT activity for the return item
N DIC,DR,DA,X,Y,DINUM,DLAYGO,DD,DO
I '$D(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITEM)) Q
S DIC="^PSD(58.35,"_PHLOC_",""BAT"","_BATCH_",""ITM"","_ITEM_",""LOG"","
S X=$$NOW^XLFDT(),DIC(0)="",DA(3)=PHLOC,DA(2)=BATCH,DA(1)=ITEM
S DIC("DR")="1////^S X=DUZ;2///^S X=TYPE;3///^S X=COMM"
K DD,DO D FILE^DICN K DD,DO
;
Q
;
DTRNG(BGN,END) ; Date Range Selection
;Input: (o) BGN - Default Begin Date
; (o) END - Default End Date
;
N %DT,DTOUT,DUOUT,DTRNG,X,Y
S DTRNG=""
S %DT="AES",%DT("A")="BEGIN DATE: ",%DT("B")=$G(BGN) K:$G(BGN)="" %DT("B") D ^%DT
I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
S $P(DTRNG,U)=Y
;
W ! K %DT
S %DT="AES",%DT("A")="END DATE: ",%DT("B")=$G(END),%DT(0)=Y K:$G(END)="" %DT("B") D ^%DT
I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
;
;Define Entry
S $P(DTRNG,U,2)=Y
;
Q DTRNG
;
STASEL() ; Status Selection
N PSARY,STR,I,DIR,X,Y
S STR="AP:AWAITING PICKUP;PU:PICKED UP;CO:COMPLETED;CA:CANCELLED;ALL:ALL"
W !,"Select one or multiple (separated by comma) of the following:"
F I=1:1:$L(STR,";") D
.S PSARY($P($P(STR,";",I),":"))=$P($P(STR,";",I),":",2)
.S DIR("A",I)=$J($P($P(STR,";",I),":"),10)_" - "_$P($P(STR,";",I),":",2)
S DIR("A",I+1)="Ex.: 'PU,CO' for PICKED UP and COMPLETED batches."
S DIR("A",I+2)=""
S DIR(0)="FO^^K:'$$STAVAL^PSARDCUT(Y,.PSARY) X",DIR("A")="STATUS(ES)"
S DIR("?")="Enter one or multiple (separated by comma) from below:"
S DIR("B")="ALL"
D ^DIR I $D(DIRUT) Q ""
S Y=$$UP^XLFSTR(Y)
I $F(Y,"ALL") S Y="ALL"
Q Y
;
STAVAL(X,PSARY) ;Checks for valid combinations of statuses
; Input - X user input to be validated
; - PSARY array contains the valid statues
; Output - Return 1 valid or 0 invalid flag
N II,FLG
I $G(X)="" Q 0
S X=$$UP^XLFSTR(X)
S FLG=1
F II=1:1:$L(X,",") D I 'FLG Q
.I $P(X,",",II)="" S FLG=0 Q
.I '$D(PSARY($P(X,",",II))) S FLG=0
Q FLG
;
UPDINV(PHLOC,BATCH,ITEM,DRUG,QTY,DISPLAY) ; - Update Drug Inventory
N TYPE,BALANCE,TIMEOUT,COMM,TRANUM,DIC,DA,X,Y,DLAYGO,MONTH,BEGBAL,PREVMON,Z,DD,DO,D0
N DINUM,DIE,DR,ENDBAL,TOTADJ,DRGMFR,EXPDT
;
W !,"Updating Inventory "_$S($G(DISPLAY):"("_$$GET1^DIQ(50,DRUG,.01)_")",1:"")_"..."
;
I '$D(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITEM)) W "Failed." H 1 Q
;
S TYPE=$O(^PSD(58.84,"B","RETURNED TO MANUFACTURER",0))
I 'TYPE D Q
. W "Failed." H 1
. D LOGACT(PHLOC,BATCH,ITEM,"X","Drug Accountability Inventory not updated: 'RETURNED TO MANUFACTURER' missing from the CS WORKSHEET file (#58.84).")
;
I '$D(^PSD(58.8,PHLOC,1,DRUG,0)) D Q
. W "Failed." H 1
. D LOGACT(PHLOC,BATCH,ITEM,"X","Drug Accountability Inventory not updated: No current inventory information for Drug/Pharmacy Location.")
;
; - Updating current inventory
F L +^PSD(58.8,PHLOC,1,DRUG):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S BALANCE=+$P($G(^PSD(58.8,PHLOC,1,DRUG,0)),"^",4)
;
F TIMEOUT=20:-1:0 L:TIMEOUT +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
I 'TIMEOUT L -^PSD(58.8,PHLOC,1,DRUG) D Q
. W "Failed." H 1
. D LOGACT(PHLOC,BATCH,ITEM,"X","Drug Accountability Inventory not updated: DRUG ACCOUNTABILITY TRANSACTION file (#58.81) locked.")
;
S DRGMFR=$$GET1^DIQ(58.3511,ITEM_","_BATCH_","_PHLOC,2)
S EXPDT=$$GET1^DIQ(58.3511,ITEM_","_BATCH_","_PHLOC,9)
S COMM=$S(QTY<0:"RETURNED",1:"CANCELLED RETURN")_" FOR CREDIT: "_$$GET1^DIQ(58.3511,ITEM_","_BATCH_","_PHLOC,15)
S TRANUM=$O(^PSD(58.81,999999999999),-1)+1
S DIC="^PSD(58.81,",DIC(0)="",(DINUM,X)=TRANUM
S DA=TRANUM
S DIC("DR")="1////^S X=TYPE;2////^S X=PHLOC;3////^S X=$$NOW^XLFDT();4////^S X=DRUG"
S DIC("DR")=DIC("DR")_";5////^S X=QTY;6////^S X=DUZ;9////^S X=(BALANCE+QTY)"
S DIC("DR")=DIC("DR")_";12////^S X=DRGMFR;14////^S X=EXPDT;15////^S X=COMM"
K DD,DO D FILE^DICN K DD,DO
L -^PSD(58.81,0)
;
S $P(^PSD(58.8,PHLOC,1,DRUG,0),"^",4)=(BALANCE+QTY)
;
L -^PSD(58.8,PHLOC,1,DRUG)
;
W "OK" H 1
Q
;
MONTH ; Monthly Activity update (Unsure if this should be done. So, not being called right now)
I '$D(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITEM)) Q
S DIC="^PSD(58.35,"_PHLOC_",""BAT"","_BATCH_",""ITM"","_ITEM_",""LOG"","
S X=$$NOW^XLFDT(),DIC(0)="",DA(3)=PHLOC,DA(2)=BATCH,DA(1)=ITEM
S DIC("DR")="1////^S X=DUZ;2///^S X=TYPE;3///^S X=COMM"
K DD,DO D FILE^DICN K DD,DO
;
S MONTH=DT\100*100
S BEGBAL=0,PREVMON=$O(^PSD(58.8,PHLOC,1,DRUG,5,MONTH),-1)
I PREVMON D
. S BEGBAL=$P(^PSD(58.8,PHLOC,1,DRUG,5,PREVMON,0),"^",4) ; Ending balance from previous month
I '$D(^PSD(58.8,PHLOC,1,DRUG,5,MONTH,0)) D
. S DIC="^PSD(58.8,"_PHLOC_",1,"_DRUG_",5,",DIC(0)=""
. S DIC("DR")="1////^S X=BEGBAL",(X,DINUM)=MONTH
. S DA(2)=PHLOC,DA(1)=DRUG
. K DD,DO D FILE^DICN K DD,DO
S Z=$G(^PSD(58.8,PHLOC,1,DRUG,5,MONTH,0))
S ENDBAL=$P(Z,"^",4),TOTADJ=$P(Z,"^",5)
S DIE="^PSD(58.8,"_PHLOC_",1,"_DRUG_",5,",DA(2)=PHLOC,DA(1)=DRUG,DA=MONTH
S DR="3////^S X="_(ENDBAL+QTY)_";7////^S X="_(TOTADJ+QTY)
D ^DIE
Q
;
DEFCTMF() ; - Returns the default Contractor/Manufacturer (if there is only 1 active)
N CTMF,CNT,DEFAULT,Z
S (CTMF,CNT)=0 F S CTMF=$O(^PSD(58.36,CTMF)) Q:'CTMF D I CNT>1 Q
. S Z=^PSD(58.36,CTMF,0) I DT<$P(Z,"^",2) Q
. S CNT=CNT+1,DEFAULT=$P(Z,"^",1)
Q $S(CNT=1:$G(DEFAULT),1:"")
;
TOTCRE(PHLOC,BATCH) ; - Return Batch Total Estimated^Actual Credit
N ITM,ESTOT,ACTOT,Z
S (ITM,ESTOT,ACTOT)=0
F S ITM=$O(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITM)) Q:'ITM D
. S Z=^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITM,0)
. S ESTOT=ESTOT+$P(Z,"^",12),ACTOT=ACTOT+$P(Z,"^",13)
Q $J(ESTOT,0,2)_"^"_$J(ACTOT,0,2)
;
LIST(PHLOC,BATCH) ; - Items List
N ITM,DSPLN,LIST,XX,DIR,Y,X,DIRUT,Z,DRNAM,CNT
S ITM=0
F S ITM=$O(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITM)) Q:'ITM D
. S Z=^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITM,0)
. S DSPLN=$E($E($$GET1^DIQ(50,+Z,.01),1,20)_" ("_$P(Z,"^",4)_")",1,36)
. S $E(DSPLN,37)=$J($P(Z,"^",18),8),$E(DSPLN,46)=$P(Z,"^",9)
. S LIST($$GET1^DIQ(50,+Z,.01),ITM)=DSPLN
;
I $D(LIST) D
. S $P(XX,"-",59)="" W !?10,XX,!?10," #",?13,"RETURN DRUG (NDC)",?49,"DISP QTY",?58,"UNIT",!?10,XX,!
. S CNT=0,DRNAM="" F S DRNAM=$O(LIST(DRNAM)) Q:DRNAM="" D I $G(DIRUT) Q
. . S ITM=0 F S ITM=$O(LIST(DRNAM,ITM)) Q:'ITM D I $G(DIRUT) Q
. . . S CNT=CNT+1 W ?10,$J(CNT,2),?13,LIST(DRNAM,ITM) I '(CNT#15) S DIR(0)="E" D ^DIR W $C(13) Q
. . . W !
Q
;
LMHDR(PHLOC,BATCH,LOCNAM) ; - Header for Batch/Item screens
N LINE,PSALOC,PSACOMB
S PSALOC=PHLOC D SITES^PSAUTL1
S LINE(1)="Pharm Location: "_$E($$GET1^DIQ(58.8,PHLOC,.01)_$G(PSACOMB),1,32)
S $E(LINE(1),51)="Date Created: "_$$DTTM^PSARDCUT($$GET1^DIQ(58.351,BATCH_","_PHLOC,3,"I"))
S LINE(2)="Batch Number : "_$$GET1^DIQ(58.351,BATCH_","_PHLOC,.01)
S $E(LINE(2),57)="Status: "_$$GET1^DIQ(58.351,BATCH_","_PHLOC,1)
S LINE(3)="Rtn Contractor: "_$E($$GET1^DIQ(58.351,BATCH_","_PHLOC,4),1,31)
S $E(LINE(3),49)="Date Picked Up: "_$$DTTM^PSARDCUT($$GET1^DIQ(58.351,BATCH_","_PHLOC,2,"I"))
S LINE(4)="Reference # : "_$$GET1^DIQ(58.351,BATCH_","_PHLOC,5)
S $E(LINE(4),45)="Total Batch Credit: $"_$P($$TOTCRE^PSARDCUT(PHLOC,BATCH),"^",2)
K VALMHDR S VALMHDR(1)=LINE(1),VALMHDR(2)=LINE(2),VALMHDR(3)=LINE(3),VALMHDR(4)=LINE(4)
Q
;
EXCEL() ; - Returns whether to capture data for Excel report.
; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
;
N EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
;
S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W !
S DIR("A")="Do you want to capture report data for an Excel document"
S DIR("?")="^D EXCHLP^PSARDCUT"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q "^"
K DIROUT,DTOUT,DUOUT,DIRUT
S EXCEL=0 I Y S EXCEL=1
;
;Display Excel display message
I EXCEL=1 D EXCMSG
;
Q EXCEL
;
EXCHLP ; - 'Do you want to capture data...' prompt
W !!," Enter: 'Y' - To capture detail report data to transfer"
W !," to an Excel document"
W !," '<CR>' - To skip this option"
W !," '^' - To quit this option"
Q
;
EXCMSG ;Display the message about capturing to an Excel file format
W !!?5,"Before continuing, please set up your terminal to capture the"
W !?5,"detail report data. On some terminals, this can be done by"
W !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
W !?5,"Incoming Data' to save to Desktop. This report may take a"
W !?5,"while to run."
W !!?5,"Note: To avoid undesired wrapping of the data saved to the"
W !?5," file, please enter '0;256;999' at the 'DEVICE:' prompt.",!
Q
;
CHKEY() ; Check for keys to use Return Drug options
I $D(^XUSEC("PSARET",DUZ))!$D(^XUSEC("PSAMGR",DUZ))!$D(^XUSEC("PSORPH",DUZ)) Q 1
W !!,"Please contact your Pharmacy Coordinator for access to this option."
W !,"The PSARET security key is required!",$C(7),!
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSARDCUT 10675 printed Sep 23, 2025@19:26:31 Page 2
PSARDCUT ;BIRM/MFR - Return Drug - Utilities ;07/01/08
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**69,72**;10/24/97;Build 2
+2 ;References to DRUG file (#50) supported by IA #2095
+3 ;References to ^PSSNDCUT supported by IA #4707
+4 ;
PHLOC() ;Select Pharmacy location
+1 NEW PSALOC,PSACNT,PSAOSIT,PSAOSITN,PSACOMB,PSAISIT,PSAISITN,PSALOCA
+2 NEW PSALOCN,PSAMENU,DIR,X,Y
+3 SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",0))
IF 'PSALOC
Begin DoDot:1
+4 WRITE !!?5,"No Drug Accountability location has been created yet."
End DoDot:1
QUIT ""
+5 ;
+6 ;If more than one pharmacy location, collect them in alpha order.
+7 SET (PSACNT,PSALOC)=0
+8 FOR
SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+9 if '$DATA(^PSD(58.8,PSALOC,0))!($PIECE($GET(^PSD(58.8,PSALOC,0)),"^")="")
QUIT
+10 IF +$GET(^PSD(58.8,PSALOC,"I"))
IF +^PSD(58.8,PSALOC,"I")'>DT
QUIT
+11 if '$ORDER(^PSD(58.8,PSALOC,1,0))
QUIT
+12 SET (PSAOSIT,PSAOSITN)=""
+13 DO SITES^PSAUTL1
+14 SET PSALOCA($PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=PSALOC_"^"_$PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB_"^"_$PIECE(^(0),"^",3)_"^"_$PIECE(^(0),"^",10)_"^"_$PIECE($GET(^PSD(58.8,PSALOC,"I")),"^")
End DoDot:1
+15 IF $ORDER(PSALOCA(""))=""
QUIT ""
+16 SET PSALOCN=""
FOR
SET PSALOCN=$ORDER(PSALOCA(PSALOCN))
if PSALOCN=""
QUIT
Begin DoDot:1
+17 SET PSALOC=0
FOR
SET PSALOC=$ORDER(PSALOCA(PSALOCN,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:2
+18 SET PSACNT=PSACNT+1
SET DIR("A",PSACNT)=PSACNT_". "_PSALOCN
+19 SET PSAMENU(PSACNT,PSALOCN,PSALOC)=""
End DoDot:2
End DoDot:1
+20 SET DIR("A",PSACNT+1)=""
+21 WRITE !,"Choose one pharmacy location:",!
+22 SET DIR(0)="NO^1:"_PSACNT
SET DIR("A")="Select PHARMACY LOCATION"
+23 SET DIR("?")="Enter the number representing the Pharmacy Location"
+24 DO ^DIR
+25 SET PSALOCN=$ORDER(PSAMENU(+Y,""))
SET PSALOC=$SELECT(PSALOCN'="":+$ORDER(PSAMENU(+Y,PSALOCN,0)),1:0)
+26 QUIT $SELECT(+PSALOC>0:PSALOCA(PSALOCN,PSALOC),1:"")
+27 ;
DTTM(DATE,SEC) ; Converts FM to MM/DD/YY@HHMM(SS) (w/ or /out seconds)
+1 ;
+2 QUIT $PIECE($$FMTE^XLFDT(DATE,"2Z"),":",1,$SELECT($GET(SEC):3,1:2))
+3 ;
LOGACT(PHLOC,BATCH,ITEM,TYPE,COMM) ; - Log an EDIT activity for the return item
+1 NEW DIC,DR,DA,X,Y,DINUM,DLAYGO,DD,DO
+2 IF '$DATA(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITEM))
QUIT
+3 SET DIC="^PSD(58.35,"_PHLOC_",""BAT"","_BATCH_",""ITM"","_ITEM_",""LOG"","
+4 SET X=$$NOW^XLFDT()
SET DIC(0)=""
SET DA(3)=PHLOC
SET DA(2)=BATCH
SET DA(1)=ITEM
+5 SET DIC("DR")="1////^S X=DUZ;2///^S X=TYPE;3///^S X=COMM"
+6 KILL DD,DO
DO FILE^DICN
KILL DD,DO
+7 ;
+8 QUIT
+9 ;
DTRNG(BGN,END) ; Date Range Selection
+1 ;Input: (o) BGN - Default Begin Date
+2 ; (o) END - Default End Date
+3 ;
+4 NEW %DT,DTOUT,DUOUT,DTRNG,X,Y
+5 SET DTRNG=""
+6 SET %DT="AES"
SET %DT("A")="BEGIN DATE: "
SET %DT("B")=$GET(BGN)
if $GET(BGN)=""
KILL %DT("B")
DO ^%DT
+7 IF $GET(DUOUT)!$GET(DTOUT)!($GET(Y)=-1)
QUIT "^"
+8 SET $PIECE(DTRNG,U)=Y
+9 ;
+10 WRITE !
KILL %DT
+11 SET %DT="AES"
SET %DT("A")="END DATE: "
SET %DT("B")=$GET(END)
SET %DT(0)=Y
if $GET(END)=""
KILL %DT("B")
DO ^%DT
+12 IF $GET(DUOUT)!$GET(DTOUT)!($GET(Y)=-1)
QUIT "^"
+13 ;
+14 ;Define Entry
+15 SET $PIECE(DTRNG,U,2)=Y
+16 ;
+17 QUIT DTRNG
+18 ;
STASEL() ; Status Selection
+1 NEW PSARY,STR,I,DIR,X,Y
+2 SET STR="AP:AWAITING PICKUP;PU:PICKED UP;CO:COMPLETED;CA:CANCELLED;ALL:ALL"
+3 WRITE !,"Select one or multiple (separated by comma) of the following:"
+4 FOR I=1:1:$LENGTH(STR,";")
Begin DoDot:1
+5 SET PSARY($PIECE($PIECE(STR,";",I),":"))=$PIECE($PIECE(STR,";",I),":",2)
+6 SET DIR("A",I)=$JUSTIFY($PIECE($PIECE(STR,";",I),":"),10)_" - "_$PIECE($PIECE(STR,";",I),":",2)
End DoDot:1
+7 SET DIR("A",I+1)="Ex.: 'PU,CO' for PICKED UP and COMPLETED batches."
+8 SET DIR("A",I+2)=""
+9 SET DIR(0)="FO^^K:'$$STAVAL^PSARDCUT(Y,.PSARY) X"
SET DIR("A")="STATUS(ES)"
+10 SET DIR("?")="Enter one or multiple (separated by comma) from below:"
+11 SET DIR("B")="ALL"
+12 DO ^DIR
IF $DATA(DIRUT)
QUIT ""
+13 SET Y=$$UP^XLFSTR(Y)
+14 IF $FIND(Y,"ALL")
SET Y="ALL"
+15 QUIT Y
+16 ;
STAVAL(X,PSARY) ;Checks for valid combinations of statuses
+1 ; Input - X user input to be validated
+2 ; - PSARY array contains the valid statues
+3 ; Output - Return 1 valid or 0 invalid flag
+4 NEW II,FLG
+5 IF $GET(X)=""
QUIT 0
+6 SET X=$$UP^XLFSTR(X)
+7 SET FLG=1
+8 FOR II=1:1:$LENGTH(X,",")
Begin DoDot:1
+9 IF $PIECE(X,",",II)=""
SET FLG=0
QUIT
+10 IF '$DATA(PSARY($PIECE(X,",",II)))
SET FLG=0
End DoDot:1
IF 'FLG
QUIT
+11 QUIT FLG
+12 ;
UPDINV(PHLOC,BATCH,ITEM,DRUG,QTY,DISPLAY) ; - Update Drug Inventory
+1 NEW TYPE,BALANCE,TIMEOUT,COMM,TRANUM,DIC,DA,X,Y,DLAYGO,MONTH,BEGBAL,PREVMON,Z,DD,DO,D0
+2 NEW DINUM,DIE,DR,ENDBAL,TOTADJ,DRGMFR,EXPDT
+3 ;
+4 WRITE !,"Updating Inventory "_$SELECT($GET(DISPLAY):"("_$$GET1^DIQ(50,DRUG,.01)_")",1:"")_"..."
+5 ;
+6 IF '$DATA(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITEM))
WRITE "Failed."
HANG 1
QUIT
+7 ;
+8 SET TYPE=$ORDER(^PSD(58.84,"B","RETURNED TO MANUFACTURER",0))
+9 IF 'TYPE
Begin DoDot:1
+10 WRITE "Failed."
HANG 1
+11 DO LOGACT(PHLOC,BATCH,ITEM,"X","Drug Accountability Inventory not updated: 'RETURNED TO MANUFACTURER' missing from the CS WORKSHEET file (#58.84).")
End DoDot:1
QUIT
+12 ;
+13 IF '$DATA(^PSD(58.8,PHLOC,1,DRUG,0))
Begin DoDot:1
+14 WRITE "Failed."
HANG 1
+15 DO LOGACT(PHLOC,BATCH,ITEM,"X","Drug Accountability Inventory not updated: No current inventory information for Drug/Pharmacy Location.")
End DoDot:1
QUIT
+16 ;
+17 ; - Updating current inventory
+18 FOR
LOCK +^PSD(58.8,PHLOC,1,DRUG):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+19 SET BALANCE=+$PIECE($GET(^PSD(58.8,PHLOC,1,DRUG,0)),"^",4)
+20 ;
+21 FOR TIMEOUT=20:-1:0
if TIMEOUT
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+22 IF 'TIMEOUT
LOCK -^PSD(58.8,PHLOC,1,DRUG)
Begin DoDot:1
+23 WRITE "Failed."
HANG 1
+24 DO LOGACT(PHLOC,BATCH,ITEM,"X","Drug Accountability Inventory not updated: DRUG ACCOUNTABILITY TRANSACTION file (#58.81) locked.")
End DoDot:1
QUIT
+25 ;
+26 SET DRGMFR=$$GET1^DIQ(58.3511,ITEM_","_BATCH_","_PHLOC,2)
+27 SET EXPDT=$$GET1^DIQ(58.3511,ITEM_","_BATCH_","_PHLOC,9)
+28 SET COMM=$SELECT(QTY<0:"RETURNED",1:"CANCELLED RETURN")_" FOR CREDIT: "_$$GET1^DIQ(58.3511,ITEM_","_BATCH_","_PHLOC,15)
+29 SET TRANUM=$ORDER(^PSD(58.81,999999999999),-1)+1
+30 SET DIC="^PSD(58.81,"
SET DIC(0)=""
SET (DINUM,X)=TRANUM
+31 SET DA=TRANUM
+32 SET DIC("DR")="1////^S X=TYPE;2////^S X=PHLOC;3////^S X=$$NOW^XLFDT();4////^S X=DRUG"
+33 SET DIC("DR")=DIC("DR")_";5////^S X=QTY;6////^S X=DUZ;9////^S X=(BALANCE+QTY)"
+34 SET DIC("DR")=DIC("DR")_";12////^S X=DRGMFR;14////^S X=EXPDT;15////^S X=COMM"
+35 KILL DD,DO
DO FILE^DICN
KILL DD,DO
+36 LOCK -^PSD(58.81,0)
+37 ;
+38 SET $PIECE(^PSD(58.8,PHLOC,1,DRUG,0),"^",4)=(BALANCE+QTY)
+39 ;
+40 LOCK -^PSD(58.8,PHLOC,1,DRUG)
+41 ;
+42 WRITE "OK"
HANG 1
+43 QUIT
+44 ;
MONTH ; Monthly Activity update (Unsure if this should be done. So, not being called right now)
+1 IF '$DATA(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITEM))
QUIT
+2 SET DIC="^PSD(58.35,"_PHLOC_",""BAT"","_BATCH_",""ITM"","_ITEM_",""LOG"","
+3 SET X=$$NOW^XLFDT()
SET DIC(0)=""
SET DA(3)=PHLOC
SET DA(2)=BATCH
SET DA(1)=ITEM
+4 SET DIC("DR")="1////^S X=DUZ;2///^S X=TYPE;3///^S X=COMM"
+5 KILL DD,DO
DO FILE^DICN
KILL DD,DO
+6 ;
+7 SET MONTH=DT\100*100
+8 SET BEGBAL=0
SET PREVMON=$ORDER(^PSD(58.8,PHLOC,1,DRUG,5,MONTH),-1)
+9 IF PREVMON
Begin DoDot:1
+10 ; Ending balance from previous month
SET BEGBAL=$PIECE(^PSD(58.8,PHLOC,1,DRUG,5,PREVMON,0),"^",4)
End DoDot:1
+11 IF '$DATA(^PSD(58.8,PHLOC,1,DRUG,5,MONTH,0))
Begin DoDot:1
+12 SET DIC="^PSD(58.8,"_PHLOC_",1,"_DRUG_",5,"
SET DIC(0)=""
+13 SET DIC("DR")="1////^S X=BEGBAL"
SET (X,DINUM)=MONTH
+14 SET DA(2)=PHLOC
SET DA(1)=DRUG
+15 KILL DD,DO
DO FILE^DICN
KILL DD,DO
End DoDot:1
+16 SET Z=$GET(^PSD(58.8,PHLOC,1,DRUG,5,MONTH,0))
+17 SET ENDBAL=$PIECE(Z,"^",4)
SET TOTADJ=$PIECE(Z,"^",5)
+18 SET DIE="^PSD(58.8,"_PHLOC_",1,"_DRUG_",5,"
SET DA(2)=PHLOC
SET DA(1)=DRUG
SET DA=MONTH
+19 SET DR="3////^S X="_(ENDBAL+QTY)_";7////^S X="_(TOTADJ+QTY)
+20 DO ^DIE
+21 QUIT
+22 ;
DEFCTMF() ; - Returns the default Contractor/Manufacturer (if there is only 1 active)
+1 NEW CTMF,CNT,DEFAULT,Z
+2 SET (CTMF,CNT)=0
FOR
SET CTMF=$ORDER(^PSD(58.36,CTMF))
if 'CTMF
QUIT
Begin DoDot:1
+3 SET Z=^PSD(58.36,CTMF,0)
IF DT<$PIECE(Z,"^",2)
QUIT
+4 SET CNT=CNT+1
SET DEFAULT=$PIECE(Z,"^",1)
End DoDot:1
IF CNT>1
QUIT
+5 QUIT $SELECT(CNT=1:$GET(DEFAULT),1:"")
+6 ;
TOTCRE(PHLOC,BATCH) ; - Return Batch Total Estimated^Actual Credit
+1 NEW ITM,ESTOT,ACTOT,Z
+2 SET (ITM,ESTOT,ACTOT)=0
+3 FOR
SET ITM=$ORDER(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITM))
if 'ITM
QUIT
Begin DoDot:1
+4 SET Z=^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITM,0)
+5 SET ESTOT=ESTOT+$PIECE(Z,"^",12)
SET ACTOT=ACTOT+$PIECE(Z,"^",13)
End DoDot:1
+6 QUIT $JUSTIFY(ESTOT,0,2)_"^"_$JUSTIFY(ACTOT,0,2)
+7 ;
LIST(PHLOC,BATCH) ; - Items List
+1 NEW ITM,DSPLN,LIST,XX,DIR,Y,X,DIRUT,Z,DRNAM,CNT
+2 SET ITM=0
+3 FOR
SET ITM=$ORDER(^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITM))
if 'ITM
QUIT
Begin DoDot:1
+4 SET Z=^PSD(58.35,PHLOC,"BAT",BATCH,"ITM",ITM,0)
+5 SET DSPLN=$EXTRACT($EXTRACT($$GET1^DIQ(50,+Z,.01),1,20)_" ("_$PIECE(Z,"^",4)_")",1,36)
+6 SET $EXTRACT(DSPLN,37)=$JUSTIFY($PIECE(Z,"^",18),8)
SET $EXTRACT(DSPLN,46)=$PIECE(Z,"^",9)
+7 SET LIST($$GET1^DIQ(50,+Z,.01),ITM)=DSPLN
End DoDot:1
+8 ;
+9 IF $DATA(LIST)
Begin DoDot:1
+10 SET $PIECE(XX,"-",59)=""
WRITE !?10,XX,!?10," #",?13,"RETURN DRUG (NDC)",?49,"DISP QTY",?58,"UNIT",!?10,XX,!
+11 SET CNT=0
SET DRNAM=""
FOR
SET DRNAM=$ORDER(LIST(DRNAM))
if DRNAM=""
QUIT
Begin DoDot:2
+12 SET ITM=0
FOR
SET ITM=$ORDER(LIST(DRNAM,ITM))
if 'ITM
QUIT
Begin DoDot:3
+13 SET CNT=CNT+1
WRITE ?10,$JUSTIFY(CNT,2),?13,LIST(DRNAM,ITM)
IF '(CNT#15)
SET DIR(0)="E"
DO ^DIR
WRITE $CHAR(13)
QUIT
+14 WRITE !
End DoDot:3
IF $GET(DIRUT)
QUIT
End DoDot:2
IF $GET(DIRUT)
QUIT
End DoDot:1
+15 QUIT
+16 ;
LMHDR(PHLOC,BATCH,LOCNAM) ; - Header for Batch/Item screens
+1 NEW LINE,PSALOC,PSACOMB
+2 SET PSALOC=PHLOC
DO SITES^PSAUTL1
+3 SET LINE(1)="Pharm Location: "_$EXTRACT($$GET1^DIQ(58.8,PHLOC,.01)_$GET(PSACOMB),1,32)
+4 SET $EXTRACT(LINE(1),51)="Date Created: "_$$DTTM^PSARDCUT($$GET1^DIQ(58.351,BATCH_","_PHLOC,3,"I"))
+5 SET LINE(2)="Batch Number : "_$$GET1^DIQ(58.351,BATCH_","_PHLOC,.01)
+6 SET $EXTRACT(LINE(2),57)="Status: "_$$GET1^DIQ(58.351,BATCH_","_PHLOC,1)
+7 SET LINE(3)="Rtn Contractor: "_$EXTRACT($$GET1^DIQ(58.351,BATCH_","_PHLOC,4),1,31)
+8 SET $EXTRACT(LINE(3),49)="Date Picked Up: "_$$DTTM^PSARDCUT($$GET1^DIQ(58.351,BATCH_","_PHLOC,2,"I"))
+9 SET LINE(4)="Reference # : "_$$GET1^DIQ(58.351,BATCH_","_PHLOC,5)
+10 SET $EXTRACT(LINE(4),45)="Total Batch Credit: $"_$PIECE($$TOTCRE^PSARDCUT(PHLOC,BATCH),"^",2)
+11 KILL VALMHDR
SET VALMHDR(1)=LINE(1)
SET VALMHDR(2)=LINE(2)
SET VALMHDR(3)=LINE(3)
SET VALMHDR(4)=LINE(4)
+12 QUIT
+13 ;
EXCEL() ; - Returns whether to capture data for Excel report.
+1 ; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
+2 ;
+3 NEW EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
+4 ;
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("T")=DTIME
WRITE !
+6 SET DIR("A")="Do you want to capture report data for an Excel document"
+7 SET DIR("?")="^D EXCHLP^PSARDCUT"
+8 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT "^"
+9 KILL DIROUT,DTOUT,DUOUT,DIRUT
+10 SET EXCEL=0
IF Y
SET EXCEL=1
+11 ;
+12 ;Display Excel display message
+13 IF EXCEL=1
DO EXCMSG
+14 ;
+15 QUIT EXCEL
+16 ;
EXCHLP ; - 'Do you want to capture data...' prompt
+1 WRITE !!," Enter: 'Y' - To capture detail report data to transfer"
+2 WRITE !," to an Excel document"
+3 WRITE !," '<CR>' - To skip this option"
+4 WRITE !," '^' - To quit this option"
+5 QUIT
+6 ;
EXCMSG ;Display the message about capturing to an Excel file format
+1 WRITE !!?5,"Before continuing, please set up your terminal to capture the"
+2 WRITE !?5,"detail report data. On some terminals, this can be done by"
+3 WRITE !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
+4 WRITE !?5,"Incoming Data' to save to Desktop. This report may take a"
+5 WRITE !?5,"while to run."
+6 WRITE !!?5,"Note: To avoid undesired wrapping of the data saved to the"
+7 WRITE !?5," file, please enter '0;256;999' at the 'DEVICE:' prompt.",!
+8 QUIT
+9 ;
CHKEY() ; Check for keys to use Return Drug options
+1 IF $DATA(^XUSEC("PSARET",DUZ))!$DATA(^XUSEC("PSAMGR",DUZ))!$DATA(^XUSEC("PSORPH",DUZ))
QUIT 1
+2 WRITE !!,"Please contact your Pharmacy Coordinator for access to this option."
+3 WRITE !,"The PSARET security key is required!",$CHAR(7),!
+4 QUIT 0
