PSARDCU1 ;BIRM/MFR - Return Drug - Utilities (Cont.) ;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
;
ITEM(PHARMLOC,BATCH,ITEM,QUIT) ; - Add/Edit Item
N FIELDS,PSAMFR,PSANDC,PSAUPC,PSAORDUN,PSAQTYOU,PSAQTYDU,PSADUOU,PSADSPUN
N PSADUNAM,PSAESTCR,PSAACTCR,PSACOST,PSAUPINV,PSAREAS,PSAEXPDT,PSADRNAM
N PSADRUG,PSAUSER,DATA,OLDDATA,NEWDATA,PSAOUNAM,PRPT,EXPDT,DIC,DIR,Y,X
;
D LOAD()
;
DRUG ; - Drug
K DIC,Y,X
S DIC="^PSDRUG(",DIC(0)="QEAM",DIC("A")="DRUG: "
S DIC("B")=$G(PSADRNAM) K:DIC("B")="" DIC("B")
D ^DIC I $D(DTOUT) G END
I X=""!('$G(PSADRUG)&(X["^"&(X'="^"))) D G DRUG
. W !,"This is a required response. Enter '^' to exit"
I $D(DUOUT) G @$$GOTO(X,"DRUG")
S PSADRUG=+Y,PSADRNAM=$$GET1^DIQ(50,PSADRUG,.01)
I 'PSAORDUN S PSAORDUN=$$GET1^DIQ(50,PSADRUG,12,"I")
I PSAORDUN S PSAOUNAM=$$GET1^DIQ(51.5,PSAORDUN,.02)
I PSADSPUN="" S (PSADUNAM,PSADSPUN)=$$GET1^DIQ(50,PSADRUG,14.5)
I PSADUNAM="" S PSADUNAM="DISP. UNIT"
I PSADUOU="" S PSADUOU=+$$GET1^DIQ(50,PSADRUG,15)
;
MFR ; - Manufacturer
K DIR,DIRUT,DIROUT
S DIR(0)="FAO^3:30",DIR("A")="MFR: "
S DIR("B")=$G(PSAMFR) K:DIR("B")="" DIR("B")
S DIR("?")="Enter the drug manufacturer name."
D ^DIR I X'="",$D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"MFR")
I X="@" K DIR("B") S PSAMFR="" W " Deleted!" G MFR
I X="" S PSAMFR="" G NDC
S PSAMFR=X
;
NDC ; - NDC
I $G(PSANDC)["^" S PSANDC=""
D NDCEDT^PSANDCUT(PSADRUG,.PSANDC)
I PSANDC["^" S X=PSANDC,PSANDC="" G @$$GOTO(X,"NDC")
;
ORDUNT ; - Order Unit
K DIC,Y,X
I $G(PSAORDUN)="" S PSAORDUN=$$GET1^DIQ(50,PSADRUG,12,"I")
I $G(PSAORDUN) S PSAOUNAM=$$GET1^DIQ(51.5,PSAORDUN,.02)
I $$GET1^DIQ(50,PSADRUG,12,"I")'="",$G(PSAOUNAM)'="" W !,"ORDER UNIT: ",PSAOUNAM G DSPUNT
S DIC="^DIC(51.5,",DIC(0)="QEAMZ",DIC("A")="ORDER UNIT: "
S DIC("B")=$G(PSAOUNAM) K:DIC("B")="" DIC("B")
D ^DIC I X'="",$D(DTOUT)!$D(DUOUT) G @$$GOTO(X,"ORDUNT")
I X="" W !,"This is a required response. Enter '^' to exit" G ORDUNT
I Y>0 S PSAORDUN=+Y,PSAOUNAM=$P(Y(0),"^",2)
;
DSPUNT ; - Dispense Unit
I $G(PSADSPUN)="" D
. S (PSADUNAM,PSADSPUN)=$$GET1^DIQ(50,PSADRUG,14.5) I PSADUNAM="" S PSADUNAM="DISPENSE UNIT"
I $$GET1^DIQ(50,PSADRUG,14.5)'="",$G(PSADSPUN)'="" W !,"DISPENSE UNIT: ",PSADSPUN G DUOU
K DIR,DIRUT,DIROUT
S DIR(0)="FAO^1:10",DIR("A")="DISPENSE UNIT: "
S DIR("B")=$G(PSADSPUN) K:DIR("B")="" DIR("B")
S DIR("?")="Enter the drug dispense unit."
D ^DIR I X="@" K DIR("B") S PSADSPUN="" W " Deleted!" G DSPUNT
I X'="",$D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"DSPUNT")
I X="" S PSADSPUN="" G DUOU
I X?.N W " ??",$C(7) G DSPUNT
S (PSADSPUN,PSADUNAM)=X
;
DUOU ; - Number of Dispense Units per Order Unit
I $G(PSADUOU)="" S PSADUOU=+$$GET1^DIQ(50,PSADRUG,15)
S:'PSADUOU PSADUOU=""
K DIR,Y,X,PRPT
S PRPT=$S($G(PSAOUNAM)'="":PSAOUNAM,1:"ORDER UNIT")
I $$GET1^DIQ(50,PSADRUG,15),$G(PSADUOU)'="" W !,"NUMBER OF "_PSADUNAM_"(S) PER "_PRPT_": ",PSADUOU G NUMOU
S DIR(0)="NA^0.01:999999999:2",DIR("A")="NUMBER OF "_PSADUNAM_"(S) PER "_PRPT_": "
S DIR("B")=$G(PSADUOU) K:'DIR("B") DIR("B")
S DIR("?")="Enter the number of "_PSADUNAM_"(S) per "_PRPT_" being returned with a maximum of 2 decimal digits."
D ^DIR I X'="",$D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"DUOU")
S PSADUOU=Y
;
NUMOU ; - Number of Order Units Returned
K DIR,Y,X,PRPT
S PRPT=$S($G(PSAOUNAM)'="":PSAOUNAM,1:"ORDER UNIT")
S DIR(0)="NAO^0.01:999999999:2",DIR("A")="NUMBER OF "_PRPT_"(S) TO RETURN: "
S DIR("B")=$G(PSAQTYOU) K:'DIR("B") DIR("B")
S DIR("?")="Enter the number of "_PRPT_"(S) being returned with a maximum of 2 decimal digits."
D ^DIR I X'="",$D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"NUMOU")
I X="" S PSAQTYOU=X G NUMDU
S PSAQTYOU=Y
;
NUMDU ; - Number of Dispense Units Returned
K DIR,Y,X,PRPT,DEFQTY
S DEFQTY=$G(PSAQTYOU)*$G(PSADUOU)\1
S PRPT=$S($G(PSADUNAM)'="":PSADUNAM,1:"DISPENSE UNIT")
I PSAQTYDU,(PSAQTYDU'=DEFQTY) W !!,"CURRENT DISPENSE QUANTITY ON FILE: ",PSAQTYDU," ",PRPT_"(S)",!
S DIR(0)="NA^1:999999999",DIR("A")="NUMBER OF "_PRPT_"(S) TO RETURN: "
S DIR("B")=$G(DEFQTY) K:'DIR("B") DIR("B")
S DIR("?")="Enter the number of "_PRPT_"(S) being returned."
D ^DIR I $D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"NUMOU")
S PSAQTYDU=Y
;
UPC ; - UPC
K DIR,Y,X
S DIR(0)="FAO^1:20",DIR("A")="UPC: "
S DIR("B")=$G(PSAUPC) K:DIR("B")="" DIR("B")
S DIR("?")="Enter the drug UPC."
D ^DIR I X="@" K DIR("B") S PSAUPC="" W " Deleted!" G UPC
I X'="",$D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"UPC")
I X="" S PSAUPC="" G EXPDT
S PSAUPC=X
;
EXPDT ; - Expiration Date
K DIR,Y,X
N %DT,DTOUT,DUOUT
S DIR(0)="DAO^::AEST",DIR("A")="EXPIRATION DATE: "
S DIR("B")=$S($G(PSAEXPDT):$$UP^XLFSTR($$FMTE^XLFDT(PSAEXPDT)),1:"") K:DIR("B")="" DIR("B")
S DIR("?")="Enter the drug expiration date."
D ^DIR I X="@" K DIR("B") S PSAEXPDT="" W " Deleted!" G EXPDT
I X'="",$D(DUOUT)!$D(DTOUT) G @$$GOTO(X,"EXPDT")
I X="" S PSAEXPDT="" G REASON
S PSAEXPDT=Y
;
REASON ; - Return Reason
K DIR,DIRUT,DIROUT
S DIR(0)="58.3511,15",DIR("B")=$G(PSAREAS) K:DIR("B")="" DIR("B")
S DIR("A")="RETURN REASON" D ^DIR I X'="",$D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"REASON")
I X="" W !,"This is a required response. Enter '^' to exit" G REASON
S PSAREAS=Y
;
UPDINV ; - Update Inventory?
K DIR,DIRUT,DIROUT,PSAUIEXT
S DIR(0)="SA^Y:YES;N:NO"
S PSAUIEXT="NO" I $G(PSAUPINV) S PSAUIEXT="YES"
S DIR("B")=$G(PSAUIEXT) K:DIR("B")="" DIR("B")
S DIR("A")="UPDATE INVENTORY: " D ^DIR I $D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"UPDINV")
I Y="Y",'$D(^PSD(58.8,PHARMLOC,1,PSADRUG,0)) D G UPDINV
. W !!?5,"Cannot update inventory. There is no inventory"
. W !?5,"information for this Drug/Pharmacy Location.",!,$C(7)
. S PSAUPINV=0
S PSAUPINV=$S(Y="Y":1,1:0)
;
CONF ; - Confirm?
W ! S DIR(0)="YA",DIR("B")="YES",DIR("A")="Save Item? "
D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y=0) G @$$GOTO(X,"CONF")
;
I '$$CHKREQ() G @$$GOTO("^DRUG","CONF")
;
D SAVE(),AUDIT()
;
END S QUIT=0 I $D(DTOUT)!$D(DIROUT)!$D(DIRUT)!$D(DUOUT) S QUIT=1
Q
;
GOTO(INPUT,HOME) ; - Directed up-arrow
N GOTO,TAG,TRGT
I $P(INPUT,"^",2)="" Q "END"
S INPUT=$$UP^XLFSTR(INPUT)
;
S TRGT=$P(INPUT,"^",2)
S TAG("DRUG")="DRUG"
S TAG("MFR")="MFR"
S TAG("NDC")="NDC"
S TAG("ORDER UNIT")="ORDUNT"
S TAG("DISPENSE UNIT")="DSPUNT"
S TAG("NUMBER OF "_$G(PSAOUNAM))="NUMOU"
S TAG("NUMBER OF "_$G(PSADUNAM)_"(S) PER")="DUOU"
S TAG("NUMBER OF "_$G(PSADUNAM)_"(S) TO RETURN")="NUMDU"
S TAG("UPC")="UPC"
S TAG("EXPIRATION DATE")="EXPDT"
S TAG("RETURN REASON")="REASON"
S TAG("UPDATE INVENTORY")="UPDINV"
;
S GOTO=HOME
S TAG="" F S TAG=$O(TAG(TAG)) Q:TAG="" I $E(TAG,1,$L(TRGT))=TRGT S GOTO=TAG(TAG) Q
I GOTO=HOME W " ??",$C(7)
;
Q GOTO
;
LOAD() ; - Load existing item information
S FIELDS=".01;1;2;3;4;5;6;7;8;9;14;15;17"
S (PSADRUG,PSAMFR,PSANDC,PSAUPC,PSAORDUN,PSAQTYOU,PSAQTYDU,PSADUOU,EXPDT)=""
S (PSADSPUN,PSAESTCR,PSAACTCR,PSACOST,PSAUPINV,PSAREAS,PSAUSER)=""
;
I '$G(ITEM) Q
;
K DATA D GETS^DIQ(58.3511,ITEM_","_BATCH_","_PHARMLOC_",",FIELDS,"IE","DATA")
K OLDDATA M OLDDATA=DATA(58.3511,ITEM_","_BATCH_","_PHARMLOC_",")
;
S PSADRUG=OLDDATA(.01,"I"),PSADRNAM=OLDDATA(.01,"E"),PSAMFR=OLDDATA(2,"I")
S PSANDC=OLDDATA(3,"I"),PSAUPC=OLDDATA(4,"I"),PSAORDUN=$G(OLDDATA(5,"I"))
S PSAQTYOU=OLDDATA(6,"I"),PSADUOU=OLDDATA(7,"I"),PSADSPUN=OLDDATA(8,"I")
S PSAEXPDT=OLDDATA(9,"I"),PSAUPINV=OLDDATA(14,"I"),PSAREAS=OLDDATA(15,"I")
S PSAUSER=$G(OLDDATA(16,"I")),PSAQTYDU=OLDDATA(17,"I")
;
I $G(PSAORDUN) S PSAOUNAM=$$GET1^DIQ(51.5,PSAORDUN,.02)
S PSADUNAM=PSADSPUN I PSADUNAM="" S PSADUNAM="DISP. UNIT"
Q
;
CHKREQ() ; - Checking for required fields
I '$G(PSAORDUN)!'$G(PSAQTYDU)!'$G(PSADUOU)!($G(PSAREAS)="") D Q 0
. W !!?5,"The following required field(s) are missing:",$C(7),!
. W:'$G(PSAORDUN) !?10,"ORDER UNIT"
. W:'$G(PSADUOU) !?10,"NUMBER OF DISPENSE UNITS PER ORDER UNIT"
. W:'$G(PSAQTYDU) !?10,"NUMBER OF DISPENSE UNITS TO RETURN"
. W:$G(PSAREAS)="" !?10,"RETURN REASON"
. W !
Q 1
;
SAVE() ; - Saves Item
N DIE,DR,DA,NEWITEM
;
W !!,"Saving..."
;
S NEWITEM=0,DA(2)=PHARMLOC,DA(1)=BATCH
I '$G(ITEM) D
. N DIC,DR,X,DINUM,DLAYGO,DD,DO
. S DIC="^PSD(58.35,"_PHARMLOC_",""BAT"","_BATCH_",""ITM"",",X=PSADRUG,DIC(0)=""
. S DIC("DR")="1////"_$$NOW^XLFDT()_";10///P;16////"_DUZ
. K DD,DO D FILE^DICN K DD,DO
. S ITEM=+Y,NEWITEM=1
;
S DR=".01////"_PSADRUG_";2///^S X=$S(PSAMFR'="""":PSAMFR,1:""@"");3///^S X=$S(PSANDC'="""":PSANDC,1:""@"")"
S DR=DR_";4///^S X=PSAUPC;5////^S X=PSAORDUN;6///^S X=PSAQTYOU;7///^S X=PSADUOU"
S DR=DR_";8///^S X=$S(PSADSPUN'="""":PSADSPUN,1:""@"");9///^S X=$S(PSAEXPDT'="""":PSAEXPDT,1:""@"")"
S DR=DR_";14///^S X=PSAUPINV;15///^S X=PSAREAS;17///^S X=PSAQTYDU"
;
S DIE="^PSD(58.35,"_PHARMLOC_",""BAT"","_BATCH_",""ITM"",",DA=ITEM
D ^DIE W "OK" H 1
I NEWITEM,PSAUPINV D UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,PSADRUG,-PSAQTYDU)
Q
;
AUDIT() ; - Activity Log/Inventory Update
I $D(OLDDATA) D
. N FLD K DATA D GETS^DIQ(58.3511,ITEM_","_BATCH_","_PHARMLOC_",",FIELDS,"IE","DATA")
. K NEWDATA M NEWDATA=DATA(58.3511,ITEM_","_BATCH_","_PHARMLOC_",")
. S FLD=""
. F S FLD=$O(OLDDATA(FLD)) Q:FLD="" D
. . I OLDDATA(FLD,"E")'=NEWDATA(FLD,"E") D
. . . D LOGACT(FLD,OLDDATA(FLD,"E"),NEWDATA(FLD,"E"),"E")
. . . ; DRUG changed
. . . I FLD=.01 D
. . . . I OLDDATA(14,"I") D UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,OLDDATA(.01,"I"),OLDDATA(17,"I"))
. . . . I NEWDATA(14,"I") D UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,NEWDATA(.01,"I"),-NEWDATA(17,"I"))
. . . I NEWDATA(.01,"I")'=OLDDATA(.01,"I") Q
. . . ; UPDATE INVENTORY changed
. . . I FLD=14 D
. . . . I OLDDATA(14,"I") D UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,PSADRUG,OLDDATA(17,"I"))
. . . . I NEWDATA(14,"I") D UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,PSADRUG,-NEWDATA(17,"I"))
. . . I NEWDATA(14,"I")'=OLDDATA(14,"I") Q
. . . ; DISPENSE QTY changed
. . . I FLD=17 D
. . . . I OLDDATA(14,"I") D UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,PSADRUG,(OLDDATA(17,"I")-NEWDATA(17,"I")))
Q
;
LOGACT(FIELD,OLDVALUE,NEWVALUE,TYPE,COMM) ; - Log an activity for the return item
I $G(COMM)="" D
. S COMM=$$GET1^DID(58.3511,FIELD,"","LABEL")_" "
. S COMM=COMM_"changed from "_$S(OLDVALUE="":"''",1:OLDVALUE)_" to "_$S(NEWVALUE="":"''",1:NEWVALUE)_"."
D LOGACT^PSARDCUT(PHARMLOC,BATCH,ITEM,TYPE,COMM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSARDCU1 10558 printed Sep 23, 2025@19:26:30 Page 2
PSARDCU1 ;BIRM/MFR - Return Drug - Utilities (Cont.) ;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 ;
ITEM(PHARMLOC,BATCH,ITEM,QUIT) ; - Add/Edit Item
+1 NEW FIELDS,PSAMFR,PSANDC,PSAUPC,PSAORDUN,PSAQTYOU,PSAQTYDU,PSADUOU,PSADSPUN
+2 NEW PSADUNAM,PSAESTCR,PSAACTCR,PSACOST,PSAUPINV,PSAREAS,PSAEXPDT,PSADRNAM
+3 NEW PSADRUG,PSAUSER,DATA,OLDDATA,NEWDATA,PSAOUNAM,PRPT,EXPDT,DIC,DIR,Y,X
+4 ;
+5 DO LOAD()
+6 ;
DRUG ; - Drug
+1 KILL DIC,Y,X
+2 SET DIC="^PSDRUG("
SET DIC(0)="QEAM"
SET DIC("A")="DRUG: "
+3 SET DIC("B")=$GET(PSADRNAM)
if DIC("B")=""
KILL DIC("B")
+4 DO ^DIC
IF $DATA(DTOUT)
GOTO END
+5 IF X=""!('$GET(PSADRUG)&(X["^"&(X'="^")))
Begin DoDot:1
+6 WRITE !,"This is a required response. Enter '^' to exit"
End DoDot:1
GOTO DRUG
+7 IF $DATA(DUOUT)
GOTO @$$GOTO(X,"DRUG")
+8 SET PSADRUG=+Y
SET PSADRNAM=$$GET1^DIQ(50,PSADRUG,.01)
+9 IF 'PSAORDUN
SET PSAORDUN=$$GET1^DIQ(50,PSADRUG,12,"I")
+10 IF PSAORDUN
SET PSAOUNAM=$$GET1^DIQ(51.5,PSAORDUN,.02)
+11 IF PSADSPUN=""
SET (PSADUNAM,PSADSPUN)=$$GET1^DIQ(50,PSADRUG,14.5)
+12 IF PSADUNAM=""
SET PSADUNAM="DISP. UNIT"
+13 IF PSADUOU=""
SET PSADUOU=+$$GET1^DIQ(50,PSADRUG,15)
+14 ;
MFR ; - Manufacturer
+1 KILL DIR,DIRUT,DIROUT
+2 SET DIR(0)="FAO^3:30"
SET DIR("A")="MFR: "
+3 SET DIR("B")=$GET(PSAMFR)
if DIR("B")=""
KILL DIR("B")
+4 SET DIR("?")="Enter the drug manufacturer name."
+5 DO ^DIR
IF X'=""
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"MFR")
+6 IF X="@"
KILL DIR("B")
SET PSAMFR=""
WRITE " Deleted!"
GOTO MFR
+7 IF X=""
SET PSAMFR=""
GOTO NDC
+8 SET PSAMFR=X
+9 ;
NDC ; - NDC
+1 IF $GET(PSANDC)["^"
SET PSANDC=""
+2 DO NDCEDT^PSANDCUT(PSADRUG,.PSANDC)
+3 IF PSANDC["^"
SET X=PSANDC
SET PSANDC=""
GOTO @$$GOTO(X,"NDC")
+4 ;
ORDUNT ; - Order Unit
+1 KILL DIC,Y,X
+2 IF $GET(PSAORDUN)=""
SET PSAORDUN=$$GET1^DIQ(50,PSADRUG,12,"I")
+3 IF $GET(PSAORDUN)
SET PSAOUNAM=$$GET1^DIQ(51.5,PSAORDUN,.02)
+4 IF $$GET1^DIQ(50,PSADRUG,12,"I")'=""
IF $GET(PSAOUNAM)'=""
WRITE !,"ORDER UNIT: ",PSAOUNAM
GOTO DSPUNT
+5 SET DIC="^DIC(51.5,"
SET DIC(0)="QEAMZ"
SET DIC("A")="ORDER UNIT: "
+6 SET DIC("B")=$GET(PSAOUNAM)
if DIC("B")=""
KILL DIC("B")
+7 DO ^DIC
IF X'=""
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO @$$GOTO(X,"ORDUNT")
+8 IF X=""
WRITE !,"This is a required response. Enter '^' to exit"
GOTO ORDUNT
+9 IF Y>0
SET PSAORDUN=+Y
SET PSAOUNAM=$PIECE(Y(0),"^",2)
+10 ;
DSPUNT ; - Dispense Unit
+1 IF $GET(PSADSPUN)=""
Begin DoDot:1
+2 SET (PSADUNAM,PSADSPUN)=$$GET1^DIQ(50,PSADRUG,14.5)
IF PSADUNAM=""
SET PSADUNAM="DISPENSE UNIT"
End DoDot:1
+3 IF $$GET1^DIQ(50,PSADRUG,14.5)'=""
IF $GET(PSADSPUN)'=""
WRITE !,"DISPENSE UNIT: ",PSADSPUN
GOTO DUOU
+4 KILL DIR,DIRUT,DIROUT
+5 SET DIR(0)="FAO^1:10"
SET DIR("A")="DISPENSE UNIT: "
+6 SET DIR("B")=$GET(PSADSPUN)
if DIR("B")=""
KILL DIR("B")
+7 SET DIR("?")="Enter the drug dispense unit."
+8 DO ^DIR
IF X="@"
KILL DIR("B")
SET PSADSPUN=""
WRITE " Deleted!"
GOTO DSPUNT
+9 IF X'=""
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"DSPUNT")
+10 IF X=""
SET PSADSPUN=""
GOTO DUOU
+11 IF X?.N
WRITE " ??",$CHAR(7)
GOTO DSPUNT
+12 SET (PSADSPUN,PSADUNAM)=X
+13 ;
DUOU ; - Number of Dispense Units per Order Unit
+1 IF $GET(PSADUOU)=""
SET PSADUOU=+$$GET1^DIQ(50,PSADRUG,15)
+2 if 'PSADUOU
SET PSADUOU=""
+3 KILL DIR,Y,X,PRPT
+4 SET PRPT=$SELECT($GET(PSAOUNAM)'="":PSAOUNAM,1:"ORDER UNIT")
+5 IF $$GET1^DIQ(50,PSADRUG,15)
IF $GET(PSADUOU)'=""
WRITE !,"NUMBER OF "_PSADUNAM_"(S) PER "_PRPT_": ",PSADUOU
GOTO NUMOU
+6 SET DIR(0)="NA^0.01:999999999:2"
SET DIR("A")="NUMBER OF "_PSADUNAM_"(S) PER "_PRPT_": "
+7 SET DIR("B")=$GET(PSADUOU)
if 'DIR("B")
KILL DIR("B")
+8 SET DIR("?")="Enter the number of "_PSADUNAM_"(S) per "_PRPT_" being returned with a maximum of 2 decimal digits."
+9 DO ^DIR
IF X'=""
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"DUOU")
+10 SET PSADUOU=Y
+11 ;
NUMOU ; - Number of Order Units Returned
+1 KILL DIR,Y,X,PRPT
+2 SET PRPT=$SELECT($GET(PSAOUNAM)'="":PSAOUNAM,1:"ORDER UNIT")
+3 SET DIR(0)="NAO^0.01:999999999:2"
SET DIR("A")="NUMBER OF "_PRPT_"(S) TO RETURN: "
+4 SET DIR("B")=$GET(PSAQTYOU)
if 'DIR("B")
KILL DIR("B")
+5 SET DIR("?")="Enter the number of "_PRPT_"(S) being returned with a maximum of 2 decimal digits."
+6 DO ^DIR
IF X'=""
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"NUMOU")
+7 IF X=""
SET PSAQTYOU=X
GOTO NUMDU
+8 SET PSAQTYOU=Y
+9 ;
NUMDU ; - Number of Dispense Units Returned
+1 KILL DIR,Y,X,PRPT,DEFQTY
+2 SET DEFQTY=$GET(PSAQTYOU)*$GET(PSADUOU)\1
+3 SET PRPT=$SELECT($GET(PSADUNAM)'="":PSADUNAM,1:"DISPENSE UNIT")
+4 IF PSAQTYDU
IF (PSAQTYDU'=DEFQTY)
WRITE !!,"CURRENT DISPENSE QUANTITY ON FILE: ",PSAQTYDU," ",PRPT_"(S)",!
+5 SET DIR(0)="NA^1:999999999"
SET DIR("A")="NUMBER OF "_PRPT_"(S) TO RETURN: "
+6 SET DIR("B")=$GET(DEFQTY)
if 'DIR("B")
KILL DIR("B")
+7 SET DIR("?")="Enter the number of "_PRPT_"(S) being returned."
+8 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"NUMOU")
+9 SET PSAQTYDU=Y
+10 ;
UPC ; - UPC
+1 KILL DIR,Y,X
+2 SET DIR(0)="FAO^1:20"
SET DIR("A")="UPC: "
+3 SET DIR("B")=$GET(PSAUPC)
if DIR("B")=""
KILL DIR("B")
+4 SET DIR("?")="Enter the drug UPC."
+5 DO ^DIR
IF X="@"
KILL DIR("B")
SET PSAUPC=""
WRITE " Deleted!"
GOTO UPC
+6 IF X'=""
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"UPC")
+7 IF X=""
SET PSAUPC=""
GOTO EXPDT
+8 SET PSAUPC=X
+9 ;
EXPDT ; - Expiration Date
+1 KILL DIR,Y,X
+2 NEW %DT,DTOUT,DUOUT
+3 SET DIR(0)="DAO^::AEST"
SET DIR("A")="EXPIRATION DATE: "
+4 SET DIR("B")=$SELECT($GET(PSAEXPDT):$$UP^XLFSTR($$FMTE^XLFDT(PSAEXPDT)),1:"")
if DIR("B")=""
KILL DIR("B")
+5 SET DIR("?")="Enter the drug expiration date."
+6 DO ^DIR
IF X="@"
KILL DIR("B")
SET PSAEXPDT=""
WRITE " Deleted!"
GOTO EXPDT
+7 IF X'=""
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO @$$GOTO(X,"EXPDT")
+8 IF X=""
SET PSAEXPDT=""
GOTO REASON
+9 SET PSAEXPDT=Y
+10 ;
REASON ; - Return Reason
+1 KILL DIR,DIRUT,DIROUT
+2 SET DIR(0)="58.3511,15"
SET DIR("B")=$GET(PSAREAS)
if DIR("B")=""
KILL DIR("B")
+3 SET DIR("A")="RETURN REASON"
DO ^DIR
IF X'=""
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"REASON")
+4 IF X=""
WRITE !,"This is a required response. Enter '^' to exit"
GOTO REASON
+5 SET PSAREAS=Y
+6 ;
UPDINV ; - Update Inventory?
+1 KILL DIR,DIRUT,DIROUT,PSAUIEXT
+2 SET DIR(0)="SA^Y:YES;N:NO"
+3 SET PSAUIEXT="NO"
IF $GET(PSAUPINV)
SET PSAUIEXT="YES"
+4 SET DIR("B")=$GET(PSAUIEXT)
if DIR("B")=""
KILL DIR("B")
+5 SET DIR("A")="UPDATE INVENTORY: "
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"UPDINV")
+6 IF Y="Y"
IF '$DATA(^PSD(58.8,PHARMLOC,1,PSADRUG,0))
Begin DoDot:1
+7 WRITE !!?5,"Cannot update inventory. There is no inventory"
+8 WRITE !?5,"information for this Drug/Pharmacy Location.",!,$CHAR(7)
+9 SET PSAUPINV=0
End DoDot:1
GOTO UPDINV
+10 SET PSAUPINV=$SELECT(Y="Y":1,1:0)
+11 ;
CONF ; - Confirm?
+1 WRITE !
SET DIR(0)="YA"
SET DIR("B")="YES"
SET DIR("A")="Save Item? "
+2 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y=0)
GOTO @$$GOTO(X,"CONF")
+3 ;
+4 IF '$$CHKREQ()
GOTO @$$GOTO("^DRUG","CONF")
+5 ;
+6 DO SAVE()
DO AUDIT()
+7 ;
END SET QUIT=0
IF $DATA(DTOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DUOUT)
SET QUIT=1
+1 QUIT
+2 ;
GOTO(INPUT,HOME) ; - Directed up-arrow
+1 NEW GOTO,TAG,TRGT
+2 IF $PIECE(INPUT,"^",2)=""
QUIT "END"
+3 SET INPUT=$$UP^XLFSTR(INPUT)
+4 ;
+5 SET TRGT=$PIECE(INPUT,"^",2)
+6 SET TAG("DRUG")="DRUG"
+7 SET TAG("MFR")="MFR"
+8 SET TAG("NDC")="NDC"
+9 SET TAG("ORDER UNIT")="ORDUNT"
+10 SET TAG("DISPENSE UNIT")="DSPUNT"
+11 SET TAG("NUMBER OF "_$GET(PSAOUNAM))="NUMOU"
+12 SET TAG("NUMBER OF "_$GET(PSADUNAM)_"(S) PER")="DUOU"
+13 SET TAG("NUMBER OF "_$GET(PSADUNAM)_"(S) TO RETURN")="NUMDU"
+14 SET TAG("UPC")="UPC"
+15 SET TAG("EXPIRATION DATE")="EXPDT"
+16 SET TAG("RETURN REASON")="REASON"
+17 SET TAG("UPDATE INVENTORY")="UPDINV"
+18 ;
+19 SET GOTO=HOME
+20 SET TAG=""
FOR
SET TAG=$ORDER(TAG(TAG))
if TAG=""
QUIT
IF $EXTRACT(TAG,1,$LENGTH(TRGT))=TRGT
SET GOTO=TAG(TAG)
QUIT
+21 IF GOTO=HOME
WRITE " ??",$CHAR(7)
+22 ;
+23 QUIT GOTO
+24 ;
LOAD() ; - Load existing item information
+1 SET FIELDS=".01;1;2;3;4;5;6;7;8;9;14;15;17"
+2 SET (PSADRUG,PSAMFR,PSANDC,PSAUPC,PSAORDUN,PSAQTYOU,PSAQTYDU,PSADUOU,EXPDT)=""
+3 SET (PSADSPUN,PSAESTCR,PSAACTCR,PSACOST,PSAUPINV,PSAREAS,PSAUSER)=""
+4 ;
+5 IF '$GET(ITEM)
QUIT
+6 ;
+7 KILL DATA
DO GETS^DIQ(58.3511,ITEM_","_BATCH_","_PHARMLOC_",",FIELDS,"IE","DATA")
+8 KILL OLDDATA
MERGE OLDDATA=DATA(58.3511,ITEM_","_BATCH_","_PHARMLOC_",")
+9 ;
+10 SET PSADRUG=OLDDATA(.01,"I")
SET PSADRNAM=OLDDATA(.01,"E")
SET PSAMFR=OLDDATA(2,"I")
+11 SET PSANDC=OLDDATA(3,"I")
SET PSAUPC=OLDDATA(4,"I")
SET PSAORDUN=$GET(OLDDATA(5,"I"))
+12 SET PSAQTYOU=OLDDATA(6,"I")
SET PSADUOU=OLDDATA(7,"I")
SET PSADSPUN=OLDDATA(8,"I")
+13 SET PSAEXPDT=OLDDATA(9,"I")
SET PSAUPINV=OLDDATA(14,"I")
SET PSAREAS=OLDDATA(15,"I")
+14 SET PSAUSER=$GET(OLDDATA(16,"I"))
SET PSAQTYDU=OLDDATA(17,"I")
+15 ;
+16 IF $GET(PSAORDUN)
SET PSAOUNAM=$$GET1^DIQ(51.5,PSAORDUN,.02)
+17 SET PSADUNAM=PSADSPUN
IF PSADUNAM=""
SET PSADUNAM="DISP. UNIT"
+18 QUIT
+19 ;
CHKREQ() ; - Checking for required fields
+1 IF '$GET(PSAORDUN)!'$GET(PSAQTYDU)!'$GET(PSADUOU)!($GET(PSAREAS)="")
Begin DoDot:1
+2 WRITE !!?5,"The following required field(s) are missing:",$CHAR(7),!
+3 if '$GET(PSAORDUN)
WRITE !?10,"ORDER UNIT"
+4 if '$GET(PSADUOU)
WRITE !?10,"NUMBER OF DISPENSE UNITS PER ORDER UNIT"
+5 if '$GET(PSAQTYDU)
WRITE !?10,"NUMBER OF DISPENSE UNITS TO RETURN"
+6 if $GET(PSAREAS)=""
WRITE !?10,"RETURN REASON"
+7 WRITE !
End DoDot:1
QUIT 0
+8 QUIT 1
+9 ;
SAVE() ; - Saves Item
+1 NEW DIE,DR,DA,NEWITEM
+2 ;
+3 WRITE !!,"Saving..."
+4 ;
+5 SET NEWITEM=0
SET DA(2)=PHARMLOC
SET DA(1)=BATCH
+6 IF '$GET(ITEM)
Begin DoDot:1
+7 NEW DIC,DR,X,DINUM,DLAYGO,DD,DO
+8 SET DIC="^PSD(58.35,"_PHARMLOC_",""BAT"","_BATCH_",""ITM"","
SET X=PSADRUG
SET DIC(0)=""
+9 SET DIC("DR")="1////"_$$NOW^XLFDT()_";10///P;16////"_DUZ
+10 KILL DD,DO
DO FILE^DICN
KILL DD,DO
+11 SET ITEM=+Y
SET NEWITEM=1
End DoDot:1
+12 ;
+13 SET DR=".01////"_PSADRUG_";2///^S X=$S(PSAMFR'="""":PSAMFR,1:""@"");3///^S X=$S(PSANDC'="""":PSANDC,1:""@"")"
+14 SET DR=DR_";4///^S X=PSAUPC;5////^S X=PSAORDUN;6///^S X=PSAQTYOU;7///^S X=PSADUOU"
+15 SET DR=DR_";8///^S X=$S(PSADSPUN'="""":PSADSPUN,1:""@"");9///^S X=$S(PSAEXPDT'="""":PSAEXPDT,1:""@"")"
+16 SET DR=DR_";14///^S X=PSAUPINV;15///^S X=PSAREAS;17///^S X=PSAQTYDU"
+17 ;
+18 SET DIE="^PSD(58.35,"_PHARMLOC_",""BAT"","_BATCH_",""ITM"","
SET DA=ITEM
+19 DO ^DIE
WRITE "OK"
HANG 1
+20 IF NEWITEM
IF PSAUPINV
DO UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,PSADRUG,-PSAQTYDU)
+21 QUIT
+22 ;
AUDIT() ; - Activity Log/Inventory Update
+1 IF $DATA(OLDDATA)
Begin DoDot:1
+2 NEW FLD
KILL DATA
DO GETS^DIQ(58.3511,ITEM_","_BATCH_","_PHARMLOC_",",FIELDS,"IE","DATA")
+3 KILL NEWDATA
MERGE NEWDATA=DATA(58.3511,ITEM_","_BATCH_","_PHARMLOC_",")
+4 SET FLD=""
+5 FOR
SET FLD=$ORDER(OLDDATA(FLD))
if FLD=""
QUIT
Begin DoDot:2
+6 IF OLDDATA(FLD,"E")'=NEWDATA(FLD,"E")
Begin DoDot:3
+7 DO LOGACT(FLD,OLDDATA(FLD,"E"),NEWDATA(FLD,"E"),"E")
+8 ; DRUG changed
+9 IF FLD=.01
Begin DoDot:4
+10 IF OLDDATA(14,"I")
DO UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,OLDDATA(.01,"I"),OLDDATA(17,"I"))
+11 IF NEWDATA(14,"I")
DO UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,NEWDATA(.01,"I"),-NEWDATA(17,"I"))
End DoDot:4
+12 IF NEWDATA(.01,"I")'=OLDDATA(.01,"I")
QUIT
+13 ; UPDATE INVENTORY changed
+14 IF FLD=14
Begin DoDot:4
+15 IF OLDDATA(14,"I")
DO UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,PSADRUG,OLDDATA(17,"I"))
+16 IF NEWDATA(14,"I")
DO UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,PSADRUG,-NEWDATA(17,"I"))
End DoDot:4
+17 IF NEWDATA(14,"I")'=OLDDATA(14,"I")
QUIT
+18 ; DISPENSE QTY changed
+19 IF FLD=17
Begin DoDot:4
+20 IF OLDDATA(14,"I")
DO UPDINV^PSARDCUT(PHARMLOC,BATCH,ITEM,PSADRUG,(OLDDATA(17,"I")-NEWDATA(17,"I")))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
LOGACT(FIELD,OLDVALUE,NEWVALUE,TYPE,COMM) ; - Log an activity for the return item
+1 IF $GET(COMM)=""
Begin DoDot:1
+2 SET COMM=$$GET1^DID(58.3511,FIELD,"","LABEL")_" "
+3 SET COMM=COMM_"changed from "_$SELECT(OLDVALUE="":"''",1:OLDVALUE)_" to "_$SELECT(NEWVALUE="":"''",1:NEWVALUE)_"."
End DoDot:1
+4 DO LOGACT^PSARDCUT(PHARMLOC,BATCH,ITEM,TYPE,COMM)
+5 QUIT
