PSARDCBA ;BIRM/MFR - Return Drug Batch - ListMan ;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 ORDER UNIT file (#51.5) supported by IA #1931
;
SB ; - Single Batch View/Process
N PSAPHLOC,PSABATCH,DIC,Y,X,DA
;
; - Checking for security keys (PSARET, PSAMGR or PSORPH)
I '$$CHKEY^PSARDCUT() Q
;
; - Pharmacy location selection
S PSAPHLOC=+$$PHLOC^PSARDCUT() I 'PSAPHLOC Q
;
; - Batch selection
K DIC,Y,X,DA,DTOUT,DUOUT
S DIC="^PSD(58.35,"_PSAPHLOC_",""BAT"",",DIC(0)="AQEM",DIC("A")="Select BATCH NUMBER: "
W ! D ^DIC I X=""!$D(DTOUT)!$D(DUOUT) Q
S PSABATCH=+Y
;
D EN(PSAPHLOC,PSABATCH)
Q
;
EN(PSAPHLOC,PSABATCH) ; - ListManager entry point
N PSACTMF,PSACTMFN,PSAREF,PSAQUIT
;
D LOAD()
W !,"Please wait..."
D EN^VALM("PSA RETURN DRUG BATCH")
D FULL^VALM1
G EXIT
;
HDR ; - Header
D LMHDR^PSARDCUT(PSAPHLOC,PSABATCH)
D SETHDR()
Q
;
SETHDR() ; - Displays the Header Line
N HDR
;
; - Line 1
S $E(HDR,48)="ORD",$E(HDR,52)="ORDER",$E(HDR,61)="DISP",$E(HDR,66)="DISP"
S $E(HDR,72)="ACTUAL",$E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,6)
; - Line 2
S HDR=" #",$E(HDR,5)="RETURN DRUG (NDC)",$E(HDR,48)="QTY",$E(HDR,52)="UNIT"
S $E(HDR,62)="QTY",$E(HDR,66)="UNIT",$E(HDR,72)="CREDIT($)"
S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,7)
Q
;
INIT ; - Populates the Body section for ListMan
K ^TMP("PSARDCSR",$J),^TMP("PSARDCBA",$J)
;
S VALMCNT=0
D SORT,SETLINE
S VALMSG="Select the entry # to view or ?? for more actions"
Q
;
SORT ; - Sets the line to be displayed in ListMan
N ITEM,DRUGNAM
;
S (ITEM,SEQ)=0
F S ITEM=$O(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",ITEM)) Q:'ITEM D
. S DRUGNAM=$$GET1^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC,.01) I DRUGNAM="" Q
. S ^TMP("PSARDCSR",$J,DRUGNAM,ITEM)=""
Q
;
SETLINE ; - Sets the line to be displayed in ListMan
N DRUGNAM,ITEM,LINE,SEQ,DATA,FLDS,DRUG,NDC,QTY,ORDUNT,DUQTY,DSPUNT,ACTCRD
;
S DRUGNAM="",(ITEM,SEQ)=0
F S DRUGNAM=$O(^TMP("PSARDCSR",$J,DRUGNAM)) Q:DRUGNAM="" D
. F S ITEM=$O(^TMP("PSARDCSR",$J,DRUGNAM,ITEM)) Q:'ITEM D
. . S SEQ=SEQ+1
. . D GETS^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC_",","*","IE","FLDS")
. . K DATA M DATA=FLDS(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC_",")
. . S DRUG=$E(DATA(.01,"E"),1,25),NDC=DATA(3,"E"),QTY=DATA(6,"E")
. . S ORDUNT=DATA(5,"I") I ORDUNT S ORDUNT=$E($$GET1^DIQ(51.5,ORDUNT,.02),1,6)
. . S DUQTY=DATA(17,"E"),DSPUNT=$E(DATA(8,"E"),1,6),ACTCRD=DATA(12,"I")
. . ; - Display Line
. . S LINE=$J(SEQ,3),$E(LINE,5)=DRUG_" ("_NDC_")",$E(LINE,46)=$J(QTY,5),$E(LINE,52)=ORDUNT
. . S $E(LINE,59)=$J(DUQTY,6),$E(LINE,66)=DSPUNT,$E(LINE,72)=$J(ACTCRD,9,2)
. . S ^TMP("PSARDCBA",$J,SEQ,0)=LINE,VALMCNT=VALMCNT+1
. . S ^TMP("PSARDCBA",$J,SEQ,"ITEM")=ITEM
. . S ^TMP("PSARDCBA",$J,SEQ,"DISP")=DRUG_" ("_NDC_") - Quantity: "_QTY_" ("_ORDUNT_")"
;
I '$D(^TMP("PSARDCBA",$J)) D
. S ^TMP("PSARDCBA",$J,6,0)=" This batch contains no return items."
. S VALMCNT=0
Q
;
ADD ; - Add New Item action
N PSAMORE,I,DIR,Y,PSAQUIT
I '$$LKBAT(PSAPHLOC,PSABATCH) D Q
. S VALMSG="This batch is being edited by another user!",VALMBCK="R"
;
I $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")'="AP" D Q
. S VALMSG="Only AWAITING PICKUP batches can have items added!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
D FULL^VALM1 W !
S PSAMORE=1,PSAQUIT=0,DIR("A")="Add another Item? ",DIR(0)="YA",DIR("B")="YES"
F I=1:1 Q:'PSAMORE!PSAQUIT D
. D ITEM^PSARDCU1(PSAPHLOC,PSABATCH,,.PSAQUIT) Q:PSAQUIT
. W ! D ^DIR S PSAMORE=+$G(Y) W !
;
D INIT,UNLKBAT(PSAPHLOC,PSABATCH)
S VALMBCK="R"
Q
;
CAN ; - Cancel Batch action
N DIR,DIRUT,DIROUT,ITEM,QTY,DRUG,PSACOMM
;
I '$$LKBAT(PSAPHLOC,PSABATCH) D Q
. S VALMSG="This batch is being edited by another user!",VALMBCK="R"
;
I $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CA" D Q
. S VALMSG="Batch is already CANCELLED!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
I $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CO"!($$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="PU") D Q
. S VALMSG=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1)_" batches cannot be cancelled!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
D FULL^VALM1
W ! S DIR(0)="FA^3:84",DIR("A")="COMMENTS: "
D ^DIR I $D(DIRUT)!$D(DIROUT) S VALMBCK="R" D UNLKBAT(PSAPHLOC,PSABATCH) Q
S PSACOMM=X
;
; - Confirm?
W ! S DIR(0)="YA",DIR("B")="NO",DIR("A")="Cancel Batch? "
D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y=0) S VALMBCK="R" D UNLKBAT(PSAPHLOC,PSABATCH) Q
;
W !!,"Cancelling Batch..."
S DA(1)=PSAPHLOC,DA=PSABATCH
S DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","
S DR="1///CA;6///"_$$NOW^XLFDT()_";7////"_DUZ_";8///^S X=PSACOMM"
D ^DIE
W "OK"
; - Cancel Comments / Update Drug Inventory
S ITEM=0
F S ITEM=$O(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",ITEM)) Q:'ITEM D
. D LOGACT^PSARDCUT(PSAPHLOC,PSABATCH,ITEM,"C","BATCH CANCELLED: "_PSACOMM)
. I $$GET1^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC,14,"I") D
. . S DRUG=$$GET1^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC,.01,"I")
. . S QTY=+$$GET1^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC,17,"I")
. . D UPDINV^PSARDCUT(PSAPHLOC,PSABATCH,ITEM,DRUG,QTY,1)
D UNLKBAT(PSAPHLOC,PSABATCH) H 1
Q
;
PKP ; - Pickup Batch action
N DIR,DA,X,Y
;
I '$O(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",0)) D Q
. S VALMSG="There are no items to be picked up in this batch!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
I $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")'="AP" D Q
. S VALMSG="Only AWAITING PICKUP batches can be picked up!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
I '$$LKBAT(PSAPHLOC,PSABATCH) D Q
. S VALMSG="This batch is being edited by another user!",VALMBCK="R"
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
D FULL^VALM1
D EDIT I $G(PSAQUIT) D UNLKBAT(PSAPHLOC,PSABATCH) Q
;
W ! S DIR(0)="YA",DIR("B")="NO",DIR("A")=" Pick up Batch? "
D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y=0) S VALMBCK="R" D UNLKBAT(PSAPHLOC,PSABATCH) Q
;
S DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"",",DA(1)=PSAPHLOC,DA=PSABATCH
S DR="1////PU"_";2///^S X=$$NOW^XLFDT();4////^S X=PSACTMF;5////^S X=PSAREF"
;
D ^DIE
;
W ! S DIR(0)="YA",DIR("B")="YES",DIR("A")="Do you want to update credit for items? "
D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y=0) S VALMBCK="R" D HDR,UNLKBAT(PSAPHLOC,PSABATCH) Q
;
D CRE,UNLKBAT(PSAPHLOC,PSABATCH)
S VALMBCK="R"
Q
;
CRE ; - Update Credit action
N TYPE,SEQS,ITEM,DIR,DIE,DR,DA,I,X,Y,DIRUT,DIROUT,OLDSTS,OLDACT,OLDEST,ITEMIEN
;
I $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")'="PU" D Q
. S VALMSG="Batch status must be PICKED UP to update credit!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
I '$$LKBAT(PSAPHLOC,PSABATCH) D Q
. S VALMSG="This batch is being edited by another user!",VALMBCK="R"
;
D FULL^VALM1
K DIR,DIRUT,DIROUT,X,Y
S DIR(0)="S^E:ESTIMATED;A:ACTUAL;B:BOTH",DIR("A")="CREDIT TYPE",DIR("B")="A"
D ^DIR I $D(DIRUT)!$D(DIROUT) S VALMBCK="R" D UNLKBAT(PSAPHLOC,PSABATCH) Q
S TYPE=Y
;
K DIR,Y,X,DIRUT,DIROUT
S DIR(0)="L^1:"_VALMCNT,DIR("A")="ITEM(S)"
S DIR("?",1)="Enter one, multiple or an interval of item(s)"
S DIR("?",2)="(e.g., '1-3' for items 1, 2 and 3; '1,4,6' for"
S DIR("?",3)=" items 1, 4 and 6)"
S DIR("?",4)=""
S DIR("?")="Enter ?? to see the complete list of items."
S DIR("??")="^D LIST^PSARDCUT("_PSAPHLOC_","_PSABATCH_")"
W ! D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y'>0) S VALMBCK="R" D UNLKBAT(PSAPHLOC,PSABATCH) Q
S SEQS=Y
;
K DA,DR
S DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","_PSABATCH_",""ITM"","
S DA(2)=PSAPHLOC,DA(1)=PSABATCH
F I=1:1:$L(SEQS,",") S ITEM=$P(SEQS,",",I) Q:'ITEM D
. S (ITEMIEN,DA)=+^TMP("PSARDCBA",$J,ITEM,"ITEM")
. S OLDEST=$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11,"I")
. S OLDACT=$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12,"I")
. W !!,"Item ",ITEM,": ",^TMP("PSARDCBA",$J,ITEM,"DISP")
. S DR=$S(TYPE="E":11,TYPE="A":12,1:"11;12")
. W ! D ^DIE S DR=""
. I +OLDEST'=+$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11,"I") D
. . D LOGACT(11,$$AMT(OLDEST),$$AMT($$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11,"I")),ITEMIEN)
. I +OLDACT'=+$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12,"I") D
. . D LOGACT(12,$$AMT(OLDACT),$$AMT($$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12,"I")),ITEMIEN)
. S OLDSTS=$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),10)
. I $$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12) D
. . S DR="10////A" I OLDSTS'="ACTUAL" D LOGACT(10,OLDSTS,"ACTUAL",ITEMIEN)
. E I $$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11) D
. . S DR="10////E" I OLDSTS'="ESTIMATED" D LOGACT(10,OLDSTS,"ESTIMATED",ITEMIEN)
. I '$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12),'$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11) D
. . I $$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),10,"I")'="D",OLDSTS'="PENDING" D
. . . S DR="10////P" D LOGACT(10,OLDSTS,"PENDING",ITEMIEN)
. D ^DIE
;
D HDR,INIT,UNLKBAT(PSAPHLOC,PSABATCH)
S VALMBCK="R"
Q
;
EDT ; - Edit Batch action
N DIE,DR,DA,X,Y,DIR,DIRUT,DIROUT
;
I '$$LKBAT(PSAPHLOC,PSABATCH) D Q
. S VALMSG="This batch is being edited by another user!",VALMBCK="R"
;
I $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CO"!($$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CA") D Q
. S VALMSG=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1)_" batches cannot be edited!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
S PSACTMF=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,4,"I")
S PSACTMFN=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,4,"E")
S PSAREF=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,5,"I")
;
D FULL^VALM1
D EDIT I $G(PSAQUIT) D UNLKBAT(PSAPHLOC,PSABATCH) Q
;
W ! S DIR(0)="YA",DIR("B")="YES",DIR("A")="Save Batch? "
D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y=0) S VALMBCK="R" D UNLKBAT(PSAPHLOC,PSABATCH) Q
;
W !!,"Saving Batch..."
S DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"",",DA(1)=PSAPHLOC,DA=PSABATCH
S DR="4////^S X=PSACTMF;5////^S X=$S(PSAREF="""":""@"",1:PSAREF)"
;
D ^DIE
W "OK"
D HDR,UNLKBAT(PSAPHLOC,PSABATCH)
S VALMBCK="R"
Q
;
EDIT ; - Edit Batch action
N DIE,DIC,DIR,DR,DA,X,Y
;
S PSAQUIT=0 D FULL^VALM1 W !
K DIC,Y,X
S DIC="^PSD(58.36,",DIC(0)="QEAM",DIC("A")=" RETURN CONTRACTOR: "
S DIC("S")="I $S($P($G(^(0)),""^"",2):$P($G(^(0)),""^"",2)>DT,1:1)!(Y=$G(PSACTMF))"
I $G(PSACTMFN)'="" S DIC("B")=PSACTMFN
I $G(DIC("B"))="" S DIC("B")=$P($$DEFCTMF^PSARDCUT(),"^",2) K:DIC("B")="" DIC("B")
D ^DIC I X=""!$D(DTOUT)!$D(DUOUT) S VALMBCK="R" S PSAQUIT=1 Q
S PSACTMF=+Y,PSACTMFN=$P(Y,"^",2)
;
K DIR,DIRUT,DIROUT
I $G(PSAREF)'="" S DIR("B")=PSAREF K:DIR("B")="" DIR("B")
S DIR(0)="FAO^1:20",DIR("A")="RETURN CONTRACTOR REF#: "
S DIR("?")="Enter the pickup reference number from this contractor/manufacturer for the batch."
D ^DIR I X="@" S PSAREF="",VALMBCK="R" Q
I X'="",$D(DIRUT)!$D(DIROUT) S VALMBCK="R" S PSAQUIT=1 Q
S PSAREF=X
;
Q
;
LKBAT(PHLOC,BATCH) ; - Locks the batch
L +^PSD(58.35,PHLOC,"BAT",BATCH):+$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
Q ($T)
;
UNLKBAT(PHLOC,BATCH) ; - Unlocks the batch
L -^PSD(58.35,PHLOC,"BAT",BATCH)
Q
;
COM ; - Complete Batch action
N DIE,DA,DR,DIR,DIRUT,DIROUT,X,Y,ITM,Z
;
I '$$LKBAT(PSAPHLOC,PSABATCH) D Q
. S VALMSG="This batch is being edited by another user!",VALMBCK="R"
;
I $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CO" D Q
. S VALMSG="Batch has already been completed!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
I $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")'="PU" D Q
. S VALMSG="Only PICKED UP batches can be completed!",VALMBCK="R" W $C(7)
. D UNLKBAT(PSAPHLOC,PSABATCH)
;
D FULL^VALM1,CHKCRE(PSAPHLOC,PSABATCH)
;
; - Confirm
W ! S DIR(0)="YA",DIR("B")="NO",DIR("A")="Complete Batch? "
D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y=0) S VALMBCK="R" D UNLKBAT(PSAPHLOC,PSABATCH) Q
;
W !!,"Completing Batch..."
S DA(1)=PSAPHLOC,DA=PSABATCH
S DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","
S DR="1///CO;9///"_$$NOW^XLFDT()_";10////"_DUZ
D ^DIE
;
K DIE,DA,DR
S DA(2)=PSAPHLOC,DA(1)=PSABATCH
S ITM=0
F S ITM=$O(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",ITM)) Q:'ITM D
. S Z=^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",ITM,0)
. I '$P(Z,"^",13),$P(Z,"^",11)'="D" D
. . D LOGACT(10,$$GET1^DIQ(58.3511,ITM_","_PSABATCH_","_PSAPHLOC,10),"DENIED",ITM)
. . S DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","_PSABATCH_",""ITM"","
. . S DA=ITM,DR="10////D" D ^DIE
;
W "OK"
;
D UNLKBAT(PSAPHLOC,PSABATCH) H 1
Q
;
SEL ; - Select Item action
N PSASEL,ITEM
;
S PSASEL=+$P($P($G(Y(1)),"^",4),"=",2)
I $G(PSASEL),'$G(^TMP("PSARDCBA",$J,PSASEL,"ITEM")) D Q
. S VALMSG="Invalid selection!",VALMBCK="R" W $C(7)
;
I '$O(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",0)) D Q
. S VALMSG="There are no items to be selected in this batch!",VALMBCK="R" W $C(7)
;
I '$G(^TMP("PSARDCBA",$J,PSASEL,"ITEM")) D I 'PSASEL S VALMBCK="R" Q
. D FULL^VALM1
. N DIR,Y,X,DIRUT,DIROUT
. S DIR(0)="N^1:"_VALMCNT,DIR("A")="SELECT ITEM"
. S DIR("?",1)="Enter the item number to be selected."
. S DIR("?",2)=""
. S DIR("?")="Enter ?? to see the complete list of items."
. S DIR("??")="^D LIST^PSARDCUT("_PSAPHLOC_","_PSABATCH_")"
. W ! D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y'>0) S VALMBCK="R" Q
. S PSASEL=+Y
;
S ITEM=+^TMP("PSARDCBA",$J,PSASEL,"ITEM")
D ;
. N XQORM
. D EN^PSARDCIT(PSAPHLOC,PSABATCH,ITEM),INIT
;
S VALMBCK="R"
Q
;
EXIT ;
K ^TMP("PSARDCSR",$J),^TMP("PSARDCBA",$J)
Q
;
HELP Q
;
LOAD() ; - Load Batch information
N FLDS,DATA
S (PSACTMF,PSACTMFN,PSAREF)=""
;
K FLDS D GETS^DIQ(58.351,PSABATCH_","_PSAPHLOC_",","4;5","IE","FLDS")
K DATA M DATA=FLDS(58.351,PSABATCH_","_PSAPHLOC_",")
S PSACTMF=DATA(4,"I"),PSACTMFN=DATA(4,"E"),PSAREF=$G(DATA(5,"I"))
Q
;
CHKCRE(PHLOC,BATCH) ; - Check if Actual Credit have been entered
N ITM,DSPLN,NOCRED,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)
. I '$P(Z,"^",13),$P(Z,"^",11)'="D" D
. . S DSPLN=$E($E($$GET1^DIQ(50,+Z,.01),1,24)_" ("_$P(Z,"^",4)_")",1,40)
. . S $E(DSPLN,41)=$J($P(Z,"^",18),8),$E(DSPLN,50)=$P(Z,"^",9)
. . S NOCRED($$GET1^DIQ(50,+Z,.01),ITM)=DSPLN
;
I $D(NOCRED) D
. W !!,"WARNING: The following items will have their CREDIT STATUS"
. W !?9,"set to DENIED because no credit amount has been"
. W !?9,"entered for them:",! S $P(XX,"-",60)=""
. W !?9,XX,!?9,"RETURN DRUG (NDC)",?49,"DISP QTY",?58,"UNIT",!?9,XX,!
. S CNT=0,DRNAM="" F S DRNAM=$O(NOCRED(DRNAM)) Q:DRNAM="" D I $G(DIRUT) Q
. . S ITM=0 F S ITM=$O(NOCRED(DRNAM,ITM)) Q:'ITM D I $G(DIRUT) Q
. . . S CNT=CNT+1 W ?9,NOCRED(DRNAM,ITM) I '(CNT#15) S DIR(0)="E" D ^DIR W $C(13) Q
. . . W !
;
Q
LOGACT(FIELD,OLDVALUE,NEWVALUE,ITEM) ; - Log an activity for the return item
N COMM
S COMM=$$GET1^DID(58.3511,FIELD,"","LABEL")_" "
S COMM=COMM_$S(FIELD=10:"automatically ",1:"")_"changed from "_$S(OLDVALUE="":"''",1:OLDVALUE)_" to "_$S(NEWVALUE="":"''",1:NEWVALUE)_"."
D LOGACT^PSARDCUT(PSAPHLOC,PSABATCH,ITEM,"E",COMM)
Q
;
AMT(VAL) ; Returns the amount formatted
I $G(VAL) Q $J(VAL,0,2)
Q $G(VAL)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSARDCBA 15409 printed Sep 23, 2025@19:26:24 Page 2
PSARDCBA ;BIRM/MFR - Return Drug Batch - ListMan ;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 ORDER UNIT file (#51.5) supported by IA #1931
+4 ;
SB ; - Single Batch View/Process
+1 NEW PSAPHLOC,PSABATCH,DIC,Y,X,DA
+2 ;
+3 ; - Checking for security keys (PSARET, PSAMGR or PSORPH)
+4 IF '$$CHKEY^PSARDCUT()
QUIT
+5 ;
+6 ; - Pharmacy location selection
+7 SET PSAPHLOC=+$$PHLOC^PSARDCUT()
IF 'PSAPHLOC
QUIT
+8 ;
+9 ; - Batch selection
+10 KILL DIC,Y,X,DA,DTOUT,DUOUT
+11 SET DIC="^PSD(58.35,"_PSAPHLOC_",""BAT"","
SET DIC(0)="AQEM"
SET DIC("A")="Select BATCH NUMBER: "
+12 WRITE !
DO ^DIC
IF X=""!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+13 SET PSABATCH=+Y
+14 ;
+15 DO EN(PSAPHLOC,PSABATCH)
+16 QUIT
+17 ;
EN(PSAPHLOC,PSABATCH) ; - ListManager entry point
+1 NEW PSACTMF,PSACTMFN,PSAREF,PSAQUIT
+2 ;
+3 DO LOAD()
+4 WRITE !,"Please wait..."
+5 DO EN^VALM("PSA RETURN DRUG BATCH")
+6 DO FULL^VALM1
+7 GOTO EXIT
+8 ;
HDR ; - Header
+1 DO LMHDR^PSARDCUT(PSAPHLOC,PSABATCH)
+2 DO SETHDR()
+3 QUIT
+4 ;
SETHDR() ; - Displays the Header Line
+1 NEW HDR
+2 ;
+3 ; - Line 1
+4 SET $EXTRACT(HDR,48)="ORD"
SET $EXTRACT(HDR,52)="ORDER"
SET $EXTRACT(HDR,61)="DISP"
SET $EXTRACT(HDR,66)="DISP"
+5 SET $EXTRACT(HDR,72)="ACTUAL"
SET $EXTRACT(HDR,81)=""
DO INSTR^VALM1(IORVON_HDR_IOINORM,1,6)
+6 ; - Line 2
+7 SET HDR=" #"
SET $EXTRACT(HDR,5)="RETURN DRUG (NDC)"
SET $EXTRACT(HDR,48)="QTY"
SET $EXTRACT(HDR,52)="UNIT"
+8 SET $EXTRACT(HDR,62)="QTY"
SET $EXTRACT(HDR,66)="UNIT"
SET $EXTRACT(HDR,72)="CREDIT($)"
+9 SET $EXTRACT(HDR,81)=""
DO INSTR^VALM1(IORVON_HDR_IOINORM,1,7)
+10 QUIT
+11 ;
INIT ; - Populates the Body section for ListMan
+1 KILL ^TMP("PSARDCSR",$JOB),^TMP("PSARDCBA",$JOB)
+2 ;
+3 SET VALMCNT=0
+4 DO SORT
DO SETLINE
+5 SET VALMSG="Select the entry # to view or ?? for more actions"
+6 QUIT
+7 ;
SORT ; - Sets the line to be displayed in ListMan
+1 NEW ITEM,DRUGNAM
+2 ;
+3 SET (ITEM,SEQ)=0
+4 FOR
SET ITEM=$ORDER(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",ITEM))
if 'ITEM
QUIT
Begin DoDot:1
+5 SET DRUGNAM=$$GET1^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC,.01)
IF DRUGNAM=""
QUIT
+6 SET ^TMP("PSARDCSR",$JOB,DRUGNAM,ITEM)=""
End DoDot:1
+7 QUIT
+8 ;
SETLINE ; - Sets the line to be displayed in ListMan
+1 NEW DRUGNAM,ITEM,LINE,SEQ,DATA,FLDS,DRUG,NDC,QTY,ORDUNT,DUQTY,DSPUNT,ACTCRD
+2 ;
+3 SET DRUGNAM=""
SET (ITEM,SEQ)=0
+4 FOR
SET DRUGNAM=$ORDER(^TMP("PSARDCSR",$JOB,DRUGNAM))
if DRUGNAM=""
QUIT
Begin DoDot:1
+5 FOR
SET ITEM=$ORDER(^TMP("PSARDCSR",$JOB,DRUGNAM,ITEM))
if 'ITEM
QUIT
Begin DoDot:2
+6 SET SEQ=SEQ+1
+7 DO GETS^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC_",","*","IE","FLDS")
+8 KILL DATA
MERGE DATA=FLDS(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC_",")
+9 SET DRUG=$EXTRACT(DATA(.01,"E"),1,25)
SET NDC=DATA(3,"E")
SET QTY=DATA(6,"E")
+10 SET ORDUNT=DATA(5,"I")
IF ORDUNT
SET ORDUNT=$EXTRACT($$GET1^DIQ(51.5,ORDUNT,.02),1,6)
+11 SET DUQTY=DATA(17,"E")
SET DSPUNT=$EXTRACT(DATA(8,"E"),1,6)
SET ACTCRD=DATA(12,"I")
+12 ; - Display Line
+13 SET LINE=$JUSTIFY(SEQ,3)
SET $EXTRACT(LINE,5)=DRUG_" ("_NDC_")"
SET $EXTRACT(LINE,46)=$JUSTIFY(QTY,5)
SET $EXTRACT(LINE,52)=ORDUNT
+14 SET $EXTRACT(LINE,59)=$JUSTIFY(DUQTY,6)
SET $EXTRACT(LINE,66)=DSPUNT
SET $EXTRACT(LINE,72)=$JUSTIFY(ACTCRD,9,2)
+15 SET ^TMP("PSARDCBA",$JOB,SEQ,0)=LINE
SET VALMCNT=VALMCNT+1
+16 SET ^TMP("PSARDCBA",$JOB,SEQ,"ITEM")=ITEM
+17 SET ^TMP("PSARDCBA",$JOB,SEQ,"DISP")=DRUG_" ("_NDC_") - Quantity: "_QTY_" ("_ORDUNT_")"
End DoDot:2
End DoDot:1
+18 ;
+19 IF '$DATA(^TMP("PSARDCBA",$JOB))
Begin DoDot:1
+20 SET ^TMP("PSARDCBA",$JOB,6,0)=" This batch contains no return items."
+21 SET VALMCNT=0
End DoDot:1
+22 QUIT
+23 ;
ADD ; - Add New Item action
+1 NEW PSAMORE,I,DIR,Y,PSAQUIT
+2 IF '$$LKBAT(PSAPHLOC,PSABATCH)
Begin DoDot:1
+3 SET VALMSG="This batch is being edited by another user!"
SET VALMBCK="R"
End DoDot:1
QUIT
+4 ;
+5 IF $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")'="AP"
Begin DoDot:1
+6 SET VALMSG="Only AWAITING PICKUP batches can have items added!"
SET VALMBCK="R"
WRITE $CHAR(7)
+7 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+8 ;
+9 DO FULL^VALM1
WRITE !
+10 SET PSAMORE=1
SET PSAQUIT=0
SET DIR("A")="Add another Item? "
SET DIR(0)="YA"
SET DIR("B")="YES"
+11 FOR I=1:1
if 'PSAMORE!PSAQUIT
QUIT
Begin DoDot:1
+12 DO ITEM^PSARDCU1(PSAPHLOC,PSABATCH,,.PSAQUIT)
if PSAQUIT
QUIT
+13 WRITE !
DO ^DIR
SET PSAMORE=+$GET(Y)
WRITE !
End DoDot:1
+14 ;
+15 DO INIT
DO UNLKBAT(PSAPHLOC,PSABATCH)
+16 SET VALMBCK="R"
+17 QUIT
+18 ;
CAN ; - Cancel Batch action
+1 NEW DIR,DIRUT,DIROUT,ITEM,QTY,DRUG,PSACOMM
+2 ;
+3 IF '$$LKBAT(PSAPHLOC,PSABATCH)
Begin DoDot:1
+4 SET VALMSG="This batch is being edited by another user!"
SET VALMBCK="R"
End DoDot:1
QUIT
+5 ;
+6 IF $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CA"
Begin DoDot:1
+7 SET VALMSG="Batch is already CANCELLED!"
SET VALMBCK="R"
WRITE $CHAR(7)
+8 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+9 ;
+10 IF $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CO"!($$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="PU")
Begin DoDot:1
+11 SET VALMSG=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1)_" batches cannot be cancelled!"
SET VALMBCK="R"
WRITE $CHAR(7)
+12 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+13 ;
+14 DO FULL^VALM1
+15 WRITE !
SET DIR(0)="FA^3:84"
SET DIR("A")="COMMENTS: "
+16 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET VALMBCK="R"
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+17 SET PSACOMM=X
+18 ;
+19 ; - Confirm?
+20 WRITE !
SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="Cancel Batch? "
+21 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y=0)
SET VALMBCK="R"
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+22 ;
+23 WRITE !!,"Cancelling Batch..."
+24 SET DA(1)=PSAPHLOC
SET DA=PSABATCH
+25 SET DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","
+26 SET DR="1///CA;6///"_$$NOW^XLFDT()_";7////"_DUZ_";8///^S X=PSACOMM"
+27 DO ^DIE
+28 WRITE "OK"
+29 ; - Cancel Comments / Update Drug Inventory
+30 SET ITEM=0
+31 FOR
SET ITEM=$ORDER(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",ITEM))
if 'ITEM
QUIT
Begin DoDot:1
+32 DO LOGACT^PSARDCUT(PSAPHLOC,PSABATCH,ITEM,"C","BATCH CANCELLED: "_PSACOMM)
+33 IF $$GET1^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC,14,"I")
Begin DoDot:2
+34 SET DRUG=$$GET1^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC,.01,"I")
+35 SET QTY=+$$GET1^DIQ(58.3511,ITEM_","_PSABATCH_","_PSAPHLOC,17,"I")
+36 DO UPDINV^PSARDCUT(PSAPHLOC,PSABATCH,ITEM,DRUG,QTY,1)
End DoDot:2
End DoDot:1
+37 DO UNLKBAT(PSAPHLOC,PSABATCH)
HANG 1
+38 QUIT
+39 ;
PKP ; - Pickup Batch action
+1 NEW DIR,DA,X,Y
+2 ;
+3 IF '$ORDER(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",0))
Begin DoDot:1
+4 SET VALMSG="There are no items to be picked up in this batch!"
SET VALMBCK="R"
WRITE $CHAR(7)
+5 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+6 ;
+7 IF $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")'="AP"
Begin DoDot:1
+8 SET VALMSG="Only AWAITING PICKUP batches can be picked up!"
SET VALMBCK="R"
WRITE $CHAR(7)
+9 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+10 ;
+11 IF '$$LKBAT(PSAPHLOC,PSABATCH)
Begin DoDot:1
+12 SET VALMSG="This batch is being edited by another user!"
SET VALMBCK="R"
+13 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+14 ;
+15 DO FULL^VALM1
+16 DO EDIT
IF $GET(PSAQUIT)
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+17 ;
+18 WRITE !
SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")=" Pick up Batch? "
+19 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y=0)
SET VALMBCK="R"
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+20 ;
+21 SET DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","
SET DA(1)=PSAPHLOC
SET DA=PSABATCH
+22 SET DR="1////PU"_";2///^S X=$$NOW^XLFDT();4////^S X=PSACTMF;5////^S X=PSAREF"
+23 ;
+24 DO ^DIE
+25 ;
+26 WRITE !
SET DIR(0)="YA"
SET DIR("B")="YES"
SET DIR("A")="Do you want to update credit for items? "
+27 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y=0)
SET VALMBCK="R"
DO HDR
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+28 ;
+29 DO CRE
DO UNLKBAT(PSAPHLOC,PSABATCH)
+30 SET VALMBCK="R"
+31 QUIT
+32 ;
CRE ; - Update Credit action
+1 NEW TYPE,SEQS,ITEM,DIR,DIE,DR,DA,I,X,Y,DIRUT,DIROUT,OLDSTS,OLDACT,OLDEST,ITEMIEN
+2 ;
+3 IF $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")'="PU"
Begin DoDot:1
+4 SET VALMSG="Batch status must be PICKED UP to update credit!"
SET VALMBCK="R"
WRITE $CHAR(7)
+5 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+6 ;
+7 IF '$$LKBAT(PSAPHLOC,PSABATCH)
Begin DoDot:1
+8 SET VALMSG="This batch is being edited by another user!"
SET VALMBCK="R"
End DoDot:1
QUIT
+9 ;
+10 DO FULL^VALM1
+11 KILL DIR,DIRUT,DIROUT,X,Y
+12 SET DIR(0)="S^E:ESTIMATED;A:ACTUAL;B:BOTH"
SET DIR("A")="CREDIT TYPE"
SET DIR("B")="A"
+13 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET VALMBCK="R"
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+14 SET TYPE=Y
+15 ;
+16 KILL DIR,Y,X,DIRUT,DIROUT
+17 SET DIR(0)="L^1:"_VALMCNT
SET DIR("A")="ITEM(S)"
+18 SET DIR("?",1)="Enter one, multiple or an interval of item(s)"
+19 SET DIR("?",2)="(e.g., '1-3' for items 1, 2 and 3; '1,4,6' for"
+20 SET DIR("?",3)=" items 1, 4 and 6)"
+21 SET DIR("?",4)=""
+22 SET DIR("?")="Enter ?? to see the complete list of items."
+23 SET DIR("??")="^D LIST^PSARDCUT("_PSAPHLOC_","_PSABATCH_")"
+24 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y'>0)
SET VALMBCK="R"
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+25 SET SEQS=Y
+26 ;
+27 KILL DA,DR
+28 SET DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","_PSABATCH_",""ITM"","
+29 SET DA(2)=PSAPHLOC
SET DA(1)=PSABATCH
+30 FOR I=1:1:$LENGTH(SEQS,",")
SET ITEM=$PIECE(SEQS,",",I)
if 'ITEM
QUIT
Begin DoDot:1
+31 SET (ITEMIEN,DA)=+^TMP("PSARDCBA",$JOB,ITEM,"ITEM")
+32 SET OLDEST=$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11,"I")
+33 SET OLDACT=$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12,"I")
+34 WRITE !!,"Item ",ITEM,": ",^TMP("PSARDCBA",$JOB,ITEM,"DISP")
+35 SET DR=$SELECT(TYPE="E":11,TYPE="A":12,1:"11;12")
+36 WRITE !
DO ^DIE
SET DR=""
+37 IF +OLDEST'=+$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11,"I")
Begin DoDot:2
+38 DO LOGACT(11,$$AMT(OLDEST),$$AMT($$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11,"I")),ITEMIEN)
End DoDot:2
+39 IF +OLDACT'=+$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12,"I")
Begin DoDot:2
+40 DO LOGACT(12,$$AMT(OLDACT),$$AMT($$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12,"I")),ITEMIEN)
End DoDot:2
+41 SET OLDSTS=$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),10)
+42 IF $$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12)
Begin DoDot:2
+43 SET DR="10////A"
IF OLDSTS'="ACTUAL"
DO LOGACT(10,OLDSTS,"ACTUAL",ITEMIEN)
End DoDot:2
+44 IF '$TEST
IF $$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11)
Begin DoDot:2
+45 SET DR="10////E"
IF OLDSTS'="ESTIMATED"
DO LOGACT(10,OLDSTS,"ESTIMATED",ITEMIEN)
End DoDot:2
+46 IF '$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),12)
IF '$$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),11)
Begin DoDot:2
+47 IF $$GET1^DIQ(58.3511,DA_","_DA(1)_","_DA(2),10,"I")'="D"
IF OLDSTS'="PENDING"
Begin DoDot:3
+48 SET DR="10////P"
DO LOGACT(10,OLDSTS,"PENDING",ITEMIEN)
End DoDot:3
End DoDot:2
+49 DO ^DIE
End DoDot:1
+50 ;
+51 DO HDR
DO INIT
DO UNLKBAT(PSAPHLOC,PSABATCH)
+52 SET VALMBCK="R"
+53 QUIT
+54 ;
EDT ; - Edit Batch action
+1 NEW DIE,DR,DA,X,Y,DIR,DIRUT,DIROUT
+2 ;
+3 IF '$$LKBAT(PSAPHLOC,PSABATCH)
Begin DoDot:1
+4 SET VALMSG="This batch is being edited by another user!"
SET VALMBCK="R"
End DoDot:1
QUIT
+5 ;
+6 IF $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CO"!($$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CA")
Begin DoDot:1
+7 SET VALMSG=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1)_" batches cannot be edited!"
SET VALMBCK="R"
WRITE $CHAR(7)
+8 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+9 ;
+10 SET PSACTMF=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,4,"I")
+11 SET PSACTMFN=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,4,"E")
+12 SET PSAREF=$$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,5,"I")
+13 ;
+14 DO FULL^VALM1
+15 DO EDIT
IF $GET(PSAQUIT)
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+16 ;
+17 WRITE !
SET DIR(0)="YA"
SET DIR("B")="YES"
SET DIR("A")="Save Batch? "
+18 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y=0)
SET VALMBCK="R"
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+19 ;
+20 WRITE !!,"Saving Batch..."
+21 SET DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","
SET DA(1)=PSAPHLOC
SET DA=PSABATCH
+22 SET DR="4////^S X=PSACTMF;5////^S X=$S(PSAREF="""":""@"",1:PSAREF)"
+23 ;
+24 DO ^DIE
+25 WRITE "OK"
+26 DO HDR
DO UNLKBAT(PSAPHLOC,PSABATCH)
+27 SET VALMBCK="R"
+28 QUIT
+29 ;
EDIT ; - Edit Batch action
+1 NEW DIE,DIC,DIR,DR,DA,X,Y
+2 ;
+3 SET PSAQUIT=0
DO FULL^VALM1
WRITE !
+4 KILL DIC,Y,X
+5 SET DIC="^PSD(58.36,"
SET DIC(0)="QEAM"
SET DIC("A")=" RETURN CONTRACTOR: "
+6 SET DIC("S")="I $S($P($G(^(0)),""^"",2):$P($G(^(0)),""^"",2)>DT,1:1)!(Y=$G(PSACTMF))"
+7 IF $GET(PSACTMFN)'=""
SET DIC("B")=PSACTMFN
+8 IF $GET(DIC("B"))=""
SET DIC("B")=$PIECE($$DEFCTMF^PSARDCUT(),"^",2)
if DIC("B")=""
KILL DIC("B")
+9 DO ^DIC
IF X=""!$DATA(DTOUT)!$DATA(DUOUT)
SET VALMBCK="R"
SET PSAQUIT=1
QUIT
+10 SET PSACTMF=+Y
SET PSACTMFN=$PIECE(Y,"^",2)
+11 ;
+12 KILL DIR,DIRUT,DIROUT
+13 IF $GET(PSAREF)'=""
SET DIR("B")=PSAREF
if DIR("B")=""
KILL DIR("B")
+14 SET DIR(0)="FAO^1:20"
SET DIR("A")="RETURN CONTRACTOR REF#: "
+15 SET DIR("?")="Enter the pickup reference number from this contractor/manufacturer for the batch."
+16 DO ^DIR
IF X="@"
SET PSAREF=""
SET VALMBCK="R"
QUIT
+17 IF X'=""
IF $DATA(DIRUT)!$DATA(DIROUT)
SET VALMBCK="R"
SET PSAQUIT=1
QUIT
+18 SET PSAREF=X
+19 ;
+20 QUIT
+21 ;
LKBAT(PHLOC,BATCH) ; - Locks the batch
+1 LOCK +^PSD(58.35,PHLOC,"BAT",BATCH):+$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
+2 QUIT ($TEST)
+3 ;
UNLKBAT(PHLOC,BATCH) ; - Unlocks the batch
+1 LOCK -^PSD(58.35,PHLOC,"BAT",BATCH)
+2 QUIT
+3 ;
COM ; - Complete Batch action
+1 NEW DIE,DA,DR,DIR,DIRUT,DIROUT,X,Y,ITM,Z
+2 ;
+3 IF '$$LKBAT(PSAPHLOC,PSABATCH)
Begin DoDot:1
+4 SET VALMSG="This batch is being edited by another user!"
SET VALMBCK="R"
End DoDot:1
QUIT
+5 ;
+6 IF $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")="CO"
Begin DoDot:1
+7 SET VALMSG="Batch has already been completed!"
SET VALMBCK="R"
WRITE $CHAR(7)
+8 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+9 ;
+10 IF $$GET1^DIQ(58.351,PSABATCH_","_PSAPHLOC,1,"I")'="PU"
Begin DoDot:1
+11 SET VALMSG="Only PICKED UP batches can be completed!"
SET VALMBCK="R"
WRITE $CHAR(7)
+12 DO UNLKBAT(PSAPHLOC,PSABATCH)
End DoDot:1
QUIT
+13 ;
+14 DO FULL^VALM1
DO CHKCRE(PSAPHLOC,PSABATCH)
+15 ;
+16 ; - Confirm
+17 WRITE !
SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="Complete Batch? "
+18 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y=0)
SET VALMBCK="R"
DO UNLKBAT(PSAPHLOC,PSABATCH)
QUIT
+19 ;
+20 WRITE !!,"Completing Batch..."
+21 SET DA(1)=PSAPHLOC
SET DA=PSABATCH
+22 SET DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","
+23 SET DR="1///CO;9///"_$$NOW^XLFDT()_";10////"_DUZ
+24 DO ^DIE
+25 ;
+26 KILL DIE,DA,DR
+27 SET DA(2)=PSAPHLOC
SET DA(1)=PSABATCH
+28 SET ITM=0
+29 FOR
SET ITM=$ORDER(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",ITM))
if 'ITM
QUIT
Begin DoDot:1
+30 SET Z=^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",ITM,0)
+31 IF '$PIECE(Z,"^",13)
IF $PIECE(Z,"^",11)'="D"
Begin DoDot:2
+32 DO LOGACT(10,$$GET1^DIQ(58.3511,ITM_","_PSABATCH_","_PSAPHLOC,10),"DENIED",ITM)
+33 SET DIE="^PSD(58.35,"_PSAPHLOC_",""BAT"","_PSABATCH_",""ITM"","
+34 SET DA=ITM
SET DR="10////D"
DO ^DIE
End DoDot:2
End DoDot:1
+35 ;
+36 WRITE "OK"
+37 ;
+38 DO UNLKBAT(PSAPHLOC,PSABATCH)
HANG 1
+39 QUIT
+40 ;
SEL ; - Select Item action
+1 NEW PSASEL,ITEM
+2 ;
+3 SET PSASEL=+$PIECE($PIECE($GET(Y(1)),"^",4),"=",2)
+4 IF $GET(PSASEL)
IF '$GET(^TMP("PSARDCBA",$JOB,PSASEL,"ITEM"))
Begin DoDot:1
+5 SET VALMSG="Invalid selection!"
SET VALMBCK="R"
WRITE $CHAR(7)
End DoDot:1
QUIT
+6 ;
+7 IF '$ORDER(^PSD(58.35,PSAPHLOC,"BAT",PSABATCH,"ITM",0))
Begin DoDot:1
+8 SET VALMSG="There are no items to be selected in this batch!"
SET VALMBCK="R"
WRITE $CHAR(7)
End DoDot:1
QUIT
+9 ;
+10 IF '$GET(^TMP("PSARDCBA",$JOB,PSASEL,"ITEM"))
Begin DoDot:1
+11 DO FULL^VALM1
+12 NEW DIR,Y,X,DIRUT,DIROUT
+13 SET DIR(0)="N^1:"_VALMCNT
SET DIR("A")="SELECT ITEM"
+14 SET DIR("?",1)="Enter the item number to be selected."
+15 SET DIR("?",2)=""
+16 SET DIR("?")="Enter ?? to see the complete list of items."
+17 SET DIR("??")="^D LIST^PSARDCUT("_PSAPHLOC_","_PSABATCH_")"
+18 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y'>0)
SET VALMBCK="R"
QUIT
+19 SET PSASEL=+Y
End DoDot:1
IF 'PSASEL
SET VALMBCK="R"
QUIT
+20 ;
+21 SET ITEM=+^TMP("PSARDCBA",$JOB,PSASEL,"ITEM")
+22 ;
Begin DoDot:1
+23 NEW XQORM
+24 DO EN^PSARDCIT(PSAPHLOC,PSABATCH,ITEM)
DO INIT
End DoDot:1
+25 ;
+26 SET VALMBCK="R"
+27 QUIT
+28 ;
EXIT ;
+1 KILL ^TMP("PSARDCSR",$JOB),^TMP("PSARDCBA",$JOB)
+2 QUIT
+3 ;
HELP QUIT
+1 ;
LOAD() ; - Load Batch information
+1 NEW FLDS,DATA
+2 SET (PSACTMF,PSACTMFN,PSAREF)=""
+3 ;
+4 KILL FLDS
DO GETS^DIQ(58.351,PSABATCH_","_PSAPHLOC_",","4;5","IE","FLDS")
+5 KILL DATA
MERGE DATA=FLDS(58.351,PSABATCH_","_PSAPHLOC_",")
+6 SET PSACTMF=DATA(4,"I")
SET PSACTMFN=DATA(4,"E")
SET PSAREF=$GET(DATA(5,"I"))
+7 QUIT
+8 ;
CHKCRE(PHLOC,BATCH) ; - Check if Actual Credit have been entered
+1 NEW ITM,DSPLN,NOCRED,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 IF '$PIECE(Z,"^",13)
IF $PIECE(Z,"^",11)'="D"
Begin DoDot:2
+6 SET DSPLN=$EXTRACT($EXTRACT($$GET1^DIQ(50,+Z,.01),1,24)_" ("_$PIECE(Z,"^",4)_")",1,40)
+7 SET $EXTRACT(DSPLN,41)=$JUSTIFY($PIECE(Z,"^",18),8)
SET $EXTRACT(DSPLN,50)=$PIECE(Z,"^",9)
+8 SET NOCRED($$GET1^DIQ(50,+Z,.01),ITM)=DSPLN
End DoDot:2
End DoDot:1
+9 ;
+10 IF $DATA(NOCRED)
Begin DoDot:1
+11 WRITE !!,"WARNING: The following items will have their CREDIT STATUS"
+12 WRITE !?9,"set to DENIED because no credit amount has been"
+13 WRITE !?9,"entered for them:",!
SET $PIECE(XX,"-",60)=""
+14 WRITE !?9,XX,!?9,"RETURN DRUG (NDC)",?49,"DISP QTY",?58,"UNIT",!?9,XX,!
+15 SET CNT=0
SET DRNAM=""
FOR
SET DRNAM=$ORDER(NOCRED(DRNAM))
if DRNAM=""
QUIT
Begin DoDot:2
+16 SET ITM=0
FOR
SET ITM=$ORDER(NOCRED(DRNAM,ITM))
if 'ITM
QUIT
Begin DoDot:3
+17 SET CNT=CNT+1
WRITE ?9,NOCRED(DRNAM,ITM)
IF '(CNT#15)
SET DIR(0)="E"
DO ^DIR
WRITE $CHAR(13)
QUIT
+18 WRITE !
End DoDot:3
IF $GET(DIRUT)
QUIT
End DoDot:2
IF $GET(DIRUT)
QUIT
End DoDot:1
+19 ;
+20 QUIT
LOGACT(FIELD,OLDVALUE,NEWVALUE,ITEM) ; - Log an activity for the return item
+1 NEW COMM
+2 SET COMM=$$GET1^DID(58.3511,FIELD,"","LABEL")_" "
+3 SET COMM=COMM_$SELECT(FIELD=10:"automatically ",1:"")_"changed from "_$SELECT(OLDVALUE="":"''",1:OLDVALUE)_" to "_$SELECT(NEWVALUE="":"''",1:NEWVALUE)_"."
+4 DO LOGACT^PSARDCUT(PSAPHLOC,PSABATCH,ITEM,"E",COMM)
+5 QUIT
+6 ;
AMT(VAL) ; Returns the amount formatted
+1 IF $GET(VAL)
QUIT $JUSTIFY(VAL,0,2)
+2 QUIT $GET(VAL)
