- 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 Jan 18, 2025@02:51:35 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)