PSAREC ;BIR/LTL,JMB-Receiving Directly into Drug Accountability ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**10**; 10/24/97
;This routine receives non-prime vendor's drugs into pharmacy locations.
;The balances are incremented in the pharmacy location & the DRUG file.
;
SETUP S (PSACNT,PSAOUT)=0 D ^PSAUTL3 G:PSAOUT EXIT
S PSACHK=$O(PSALOC(""))
I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT
S PSAPO=$P($G(^PSD(58.8,+PSALOC,0)),"^",9)
I +$E($P($G(^PRC(442,+PSAPO,12)),"^",5),4,5)'=+$E(DT,4,5) W !!,"The current PO# for this location doesn't seem current.",! D G:$D(DIRUT) EXIT
.S DIR(0)="Y",DIR("A")="Would you like to correct it",DIR("B")="No",DIR("?")="You can store a obligation number and it will be presented as the default.",DIR("??")="^D CORRECT^PSAREC"
.D ^DIR K DIR Q:$D(DIRUT)!(Y<1)
.S DIE="^PSD(58.8,",DA=PSALOC,DR="13" D ^DIE K DIE
.S DIC("B")=$P($G(^PRC(442,+$P($G(^PSD(58.8,+PSALOC,0)),"^",9),0)),"^")
PO S PSAOUT=0 W ! S DIC="^PRC(442,",DIC(0)="AEMQZ"
S DIC("A")="Select Obligation Number: ",DIC("S")="I $P($G(^(0)),""^"",5)[822400" D ^DIC K DIC G:Y<1 EXIT S PSAPO=+Y,PSACON=$P($G(Y(0)),"^",12)
S DIE="^PSD(58.8,",DA=PSALOC,DR="13///^S X="+PSAPO D ^DIE K DIE
PART D START G PO
;
EXIT K %,DA,DIE,DINUM,DIRUT,DR,DTOUT,DUOUT,PSA,PSA50SYN,PSACBAL,PSACHK,PSACNT,PSACOMB,PSACON,PSACOST,PSADASH,PSADRG,PSADRGN,PSADT,PSADUOU
K PSAIEN,PSAIEN1,PSAISIT,PSAISITN,PSALEN,PSALINE,PSALOC,PSALOCN,PSANDC,PSANODE,PSANPDU,PSANPOU,PSAODASH,PSAONDC,PSAOSIT,PSAOSITN,PSAOU,PSAOUT
K PSAPDU,PSAPO,PSAPOU,PSA(2),PSAREC,PSASEL,PSAT,PSATDRG,PSAVEND,X,Y
Q
;
START S DIC="^PRCS(410,",DIC(0)="AEMQZ",DIC("A")="Select Pharmacy Transaction number: ",DIC("B")=$S($D(PSACON):$P($G(^PRCS(410,+PSACON,0)),"^"),1:""),DIC("S")="I $P($G(^(0)),""^"",2)=""O"",$P($G(^(3)),""^"",3)[822400"
D ^DIC K DIC Q:Y<1 S PSACON=$S(Y>0:+Y,1:"")
S DIR(0)="58.81,71O",DIR("A")="Invoice number",DIR("?")="The invoice will be stored, allowing look-ups for receipts against this invoice.",DIR("??")="^D INV^PSAREC"
D ^DIR K DIR Q:Y'=""&($D(DIRUT)) S PSA(2)=Y
I $G(PSA(2))'="",$O(^PSD(58.81,"PV",Y,"")) D Q:$D(DIRUT) G:Y=1 DEV^PSAREPV
.W !!,"Previous receipts have been processed for this invoice.",!! S DIR(0)="Y",DIR("A")="Would you like to review",DIR("B")="Yes" D ^DIR K DIR
;
DRUG W !!,$G(PSALOCN),!
F S DIC="^PSDRUG(",DIC(0)="AEMQ",DA(1)=PSALOC D Q:PSAOUT
.D ^DIC K DIC I Y<0 S PSAOUT=1 Q
.D GETDATA Q:$G(PSAOUT)
Q
;
GETDATA ;Gets receipts data
S PSADRG=+Y,PSADRGN=$P($G(^PSDRUG(+Y,0)),"^"),PSACBAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
NDC S DIR(0)="FO^1:15",DIR("A")="NDC",DIR("?")="Enter the National Drug Code for the drug received.",DIR("??")="^D NDCHELP^PSAREC"
D ^DIR K DIR
I $G(DIRUT) S (PSADASH,PSADUOU,PSANDC,PSAOU,PSAPOU)="",PSA50SYN=0 G OU
S:Y'="" PSADASH=Y
I PSADASH["-" S PSANDC=$E("000000",1,(6-$L($P(PSADASH,"-"))))_$P(PSADASH,"-")_$E("0000",1,(4-$L($P(PSADASH,"-",2))))_$P(PSADASH,"-",2)_$E("00",1,(2-$L($P(PSADASH,"-",3))))_$P(PSADASH,"-",3)
E S PSANDC=""
S:PSANDC'?12N PSANDC="" S (PSAOU,PSADUOU,PSAPOU)=""
I PSANDC'="",$O(^PSDRUG("C",PSANDC,PSADRG,0)) D
.S PSA50SYN=+$O(^PSDRUG("C",PSANDC,PSADRG,0))
.Q:'$D(^PSDRUG(PSADRG,1,PSA50SYN,0))
.S PSAOU=$P($G(^PSDRUG(PSADRG,1,PSA50SYN,0)),"^",5),PSADUOU=$P($G(^(0)),"^",7),PSAPOU=$P($G(^(0)),"^",6)
E S PSA50SYN=0
OU S DIC(0)="QAEMZ",DIC="^DIC(51.5,",DIC("A")="Order Unit: ",DR=.01 S:PSAOU DIC("B")=PSAOU D ^DIC K DIC
I Y<0 S PSAOUT=1 Q
S PSAOU=+Y
W !,"Dispense Units: "_$S($P($G(^PSDRUG(PSADRG,660)),"^",8)'="":$P(^PSDRUG(PSADRG,660),"^",8),1:"Unknown")
;
;DAVE B (PSA*3*10) decimal digits on Disp Units per OU
DUOU S DIR(0)="NO^::2",DIR("A")="Dispense Units per Order Unit" S:PSADUOU DIR("B")=PSADUOU
S DIR("?")="Enter the number of dispense units contained in one order unit.",DIR("??")="^D DUOUHELP^PSAPROC3" D ^DIR K DIR
I $G(DIRUT) S PSAOUT=1 Q
S PSADUOU=+Y
PRICE S DIR(0)="NO^0:9999:4",DIR("A")="Price per Order Unit",DIR("?")="Enter the price for each order unit.",DIR("??")="^D PRICEHLP^PSAREC" S:PSAPOU DIR("B")=PSAPOU D ^DIR K DIR
I $G(DIRUT) S PSAOUT=1 Q
S PSAPOU=+Y S:+PSAPOU&(PSADUOU) PSAPDU=PSAPOU/PSADUOU
QTY S DIR(0)="N^0:9999999:0",DIR("A")="Quantity received",DIR("?")="Enter the number of order units you received.",DIR("??")="^D QTYHELP^PSAREC" D ^DIR K DIR
I $D(DIRUT) S PSAOUT=1 Q
S (PSAREC,PSAREC(1))=Y,PSAVEND=$P($G(^PRC(440,+$P($G(^PRC(442,PSAPO,1)),"^"),0)),"^"),PSACOST=PSAREC*PSAPOU,PSAREC=PSADUOU*PSAREC
DISP W ?50,"Converted quantity: ",PSAREC
;
W ! S DIR(0)="Y",DIR("A")="Okay to post",DIR("B")="Yes",DIR("?",1)="Enter YES to add the received drug to the pharmacy location.",DIR("?")="Enter NO to cancel the receipt of the drug.",DIR("??")="^D POSTHELP^PSAREC"
D ^DIR K DIR I $D(DIRUT) S PSAOUT=1 Q
D:+Y POST^PSAREC1
Q
;
CORRECT ;Extended help for 'Would you like to correct it'
W !?5,"Enter YES to enter the current obligation number. It will be presented",!?5,"as the default the next time the obligation number prompt is displayed."
W !!?5,"Enter NO to keep the current obligation number as the default."
Q
;
INV ;Extended help for 'Invoice number'
W !?5,"Enter the invoice number for the receipts."
Q
NDCHELP ;Extended help for 'NDC'
W !?5,"Enter the National Drug Code (NDC) for the received drug.",!?5,"Enter the NDC with dashes or 12-digits without dashes."
Q
POSTHELP ;Extended help for 'Okay to post?'
W !?5,"Enter YES to update the balances in the pharmacy location and DRUG file",!?5,"and add a transaction."
W !?5,"Enter NO to abort receiving the drug."
Q
PRICEHLP ;Extended help for 'Price per order unit'
W !?5,"Enter the cost for each order unit."
Q
QTYHELP ;
W !?5,"The quantity entered will be multiplied by the dispense units",!?5,"per order unit to determine the number of dispense units received."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAREC 5902 printed Apr 09, 2024@20:55:48 Page 2
PSAREC ;BIR/LTL,JMB-Receiving Directly into Drug Accountability ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**10**; 10/24/97
+2 ;This routine receives non-prime vendor's drugs into pharmacy locations.
+3 ;The balances are incremented in the pharmacy location & the DRUG file.
+4 ;
SETUP SET (PSACNT,PSAOUT)=0
DO ^PSAUTL3
if PSAOUT
GOTO EXIT
+1 SET PSACHK=$ORDER(PSALOC(""))
+2 IF PSACHK=""
IF 'PSALOC
WRITE !,"There are no active pharmacy locations."
GOTO EXIT
+3 SET PSAPO=$PIECE($GET(^PSD(58.8,+PSALOC,0)),"^",9)
+4 IF +$EXTRACT($PIECE($GET(^PRC(442,+PSAPO,12)),"^",5),4,5)'=+$EXTRACT(DT,4,5)
WRITE !!,"The current PO# for this location doesn't seem current.",!
Begin DoDot:1
+5 SET DIR(0)="Y"
SET DIR("A")="Would you like to correct it"
SET DIR("B")="No"
SET DIR("?")="You can store a obligation number and it will be presented as the default."
SET DIR("??")="^D CORRECT^PSAREC"
+6 DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y<1)
QUIT
+7 SET DIE="^PSD(58.8,"
SET DA=PSALOC
SET DR="13"
DO ^DIE
KILL DIE
+8 SET DIC("B")=$PIECE($GET(^PRC(442,+$PIECE($GET(^PSD(58.8,+PSALOC,0)),"^",9),0)),"^")
End DoDot:1
if $DATA(DIRUT)
GOTO EXIT
PO SET PSAOUT=0
WRITE !
SET DIC="^PRC(442,"
SET DIC(0)="AEMQZ"
+1 SET DIC("A")="Select Obligation Number: "
SET DIC("S")="I $P($G(^(0)),""^"",5)[822400"
DO ^DIC
KILL DIC
if Y<1
GOTO EXIT
SET PSAPO=+Y
SET PSACON=$PIECE($GET(Y(0)),"^",12)
+2 SET DIE="^PSD(58.8,"
SET DA=PSALOC
SET DR="13///^S X="+PSAPO
DO ^DIE
KILL DIE
PART DO START
GOTO PO
+1 ;
EXIT KILL %,DA,DIE,DINUM,DIRUT,DR,DTOUT,DUOUT,PSA,PSA50SYN,PSACBAL,PSACHK,PSACNT,PSACOMB,PSACON,PSACOST,PSADASH,PSADRG,PSADRGN,PSADT,PSADUOU
+1 KILL PSAIEN,PSAIEN1,PSAISIT,PSAISITN,PSALEN,PSALINE,PSALOC,PSALOCN,PSANDC,PSANODE,PSANPDU,PSANPOU,PSAODASH,PSAONDC,PSAOSIT,PSAOSITN,PSAOU,PSAOUT
+2 KILL PSAPDU,PSAPO,PSAPOU,PSA(2),PSAREC,PSASEL,PSAT,PSATDRG,PSAVEND,X,Y
+3 QUIT
+4 ;
START SET DIC="^PRCS(410,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select Pharmacy Transaction number: "
SET DIC("B")=$SELECT($DATA(PSACON):$PIECE($GET(^PRCS(410,+PSACON,0)),"^"),1:"")
SET DIC("S")="I $P($G(^(0)),""^"",2)=""O"",$P($G(^(3)),""^"",3)[822400"
+1 DO ^DIC
KILL DIC
if Y<1
QUIT
SET PSACON=$SELECT(Y>0:+Y,1:"")
+2 SET DIR(0)="58.81,71O"
SET DIR("A")="Invoice number"
SET DIR("?")="The invoice will be stored, allowing look-ups for receipts against this invoice."
SET DIR("??")="^D INV^PSAREC"
+3 DO ^DIR
KILL DIR
if Y'=""&($DATA(DIRUT))
QUIT
SET PSA(2)=Y
+4 IF $GET(PSA(2))'=""
IF $ORDER(^PSD(58.81,"PV",Y,""))
Begin DoDot:1
+5 WRITE !!,"Previous receipts have been processed for this invoice.",!!
SET DIR(0)="Y"
SET DIR("A")="Would you like to review"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
End DoDot:1
if $DATA(DIRUT)
QUIT
if Y=1
GOTO DEV^PSAREPV
+6 ;
DRUG WRITE !!,$GET(PSALOCN),!
+1 FOR
SET DIC="^PSDRUG("
SET DIC(0)="AEMQ"
SET DA(1)=PSALOC
Begin DoDot:1
+2 DO ^DIC
KILL DIC
IF Y<0
SET PSAOUT=1
QUIT
+3 DO GETDATA
if $GET(PSAOUT)
QUIT
End DoDot:1
if PSAOUT
QUIT
+4 QUIT
+5 ;
GETDATA ;Gets receipts data
+1 SET PSADRG=+Y
SET PSADRGN=$PIECE($GET(^PSDRUG(+Y,0)),"^")
SET PSACBAL=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
NDC SET DIR(0)="FO^1:15"
SET DIR("A")="NDC"
SET DIR("?")="Enter the National Drug Code for the drug received."
SET DIR("??")="^D NDCHELP^PSAREC"
+1 DO ^DIR
KILL DIR
+2 IF $GET(DIRUT)
SET (PSADASH,PSADUOU,PSANDC,PSAOU,PSAPOU)=""
SET PSA50SYN=0
GOTO OU
+3 if Y'=""
SET PSADASH=Y
+4 IF PSADASH["-"
SET PSANDC=$EXTRACT("000000",1,(6-$LENGTH($PIECE(PSADASH,"-"))))_$PIECE(PSADASH,"-")_$EXTRACT("0000",1,(4-$LENGTH($PIECE(PSADASH,"-",2))))_$PIECE(PSADASH,"-",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(PSADASH,"-",3))))_$PIECE(PSADASH,"-",3)
+5 IF '$TEST
SET PSANDC=""
+6 if PSANDC'?12N
SET PSANDC=""
SET (PSAOU,PSADUOU,PSAPOU)=""
+7 IF PSANDC'=""
IF $ORDER(^PSDRUG("C",PSANDC,PSADRG,0))
Begin DoDot:1
+8 SET PSA50SYN=+$ORDER(^PSDRUG("C",PSANDC,PSADRG,0))
+9 if '$DATA(^PSDRUG(PSADRG,1,PSA50SYN,0))
QUIT
+10 SET PSAOU=$PIECE($GET(^PSDRUG(PSADRG,1,PSA50SYN,0)),"^",5)
SET PSADUOU=$PIECE($GET(^(0)),"^",7)
SET PSAPOU=$PIECE($GET(^(0)),"^",6)
End DoDot:1
+11 IF '$TEST
SET PSA50SYN=0
OU SET DIC(0)="QAEMZ"
SET DIC="^DIC(51.5,"
SET DIC("A")="Order Unit: "
SET DR=.01
if PSAOU
SET DIC("B")=PSAOU
DO ^DIC
KILL DIC
+1 IF Y<0
SET PSAOUT=1
QUIT
+2 SET PSAOU=+Y
+3 WRITE !,"Dispense Units: "_$SELECT($PIECE($GET(^PSDRUG(PSADRG,660)),"^",8)'="":$PIECE(^PSDRUG(PSADRG,660),"^",8),1:"Unknown")
+4 ;
+5 ;DAVE B (PSA*3*10) decimal digits on Disp Units per OU
DUOU SET DIR(0)="NO^::2"
SET DIR("A")="Dispense Units per Order Unit"
if PSADUOU
SET DIR("B")=PSADUOU
+1 SET DIR("?")="Enter the number of dispense units contained in one order unit."
SET DIR("??")="^D DUOUHELP^PSAPROC3"
DO ^DIR
KILL DIR
+2 IF $GET(DIRUT)
SET PSAOUT=1
QUIT
+3 SET PSADUOU=+Y
PRICE SET DIR(0)="NO^0:9999:4"
SET DIR("A")="Price per Order Unit"
SET DIR("?")="Enter the price for each order unit."
SET DIR("??")="^D PRICEHLP^PSAREC"
if PSAPOU
SET DIR("B")=PSAPOU
DO ^DIR
KILL DIR
+1 IF $GET(DIRUT)
SET PSAOUT=1
QUIT
+2 SET PSAPOU=+Y
if +PSAPOU&(PSADUOU)
SET PSAPDU=PSAPOU/PSADUOU
QTY SET DIR(0)="N^0:9999999:0"
SET DIR("A")="Quantity received"
SET DIR("?")="Enter the number of order units you received."
SET DIR("??")="^D QTYHELP^PSAREC"
DO ^DIR
KILL DIR
+1 IF $DATA(DIRUT)
SET PSAOUT=1
QUIT
+2 SET (PSAREC,PSAREC(1))=Y
SET PSAVEND=$PIECE($GET(^PRC(440,+$PIECE($GET(^PRC(442,PSAPO,1)),"^"),0)),"^")
SET PSACOST=PSAREC*PSAPOU
SET PSAREC=PSADUOU*PSAREC
DISP WRITE ?50,"Converted quantity: ",PSAREC
+1 ;
+2 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Okay to post"
SET DIR("B")="Yes"
SET DIR("?",1)="Enter YES to add the received drug to the pharmacy location."
SET DIR("?")="Enter NO to cancel the receipt of the drug."
SET DIR("??")="^D POSTHELP^PSAREC"
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSAOUT=1
QUIT
+4 if +Y
DO POST^PSAREC1
+5 QUIT
+6 ;
CORRECT ;Extended help for 'Would you like to correct it'
+1 WRITE !?5,"Enter YES to enter the current obligation number. It will be presented",!?5,"as the default the next time the obligation number prompt is displayed."
+2 WRITE !!?5,"Enter NO to keep the current obligation number as the default."
+3 QUIT
+4 ;
INV ;Extended help for 'Invoice number'
+1 WRITE !?5,"Enter the invoice number for the receipts."
+2 QUIT
NDCHELP ;Extended help for 'NDC'
+1 WRITE !?5,"Enter the National Drug Code (NDC) for the received drug.",!?5,"Enter the NDC with dashes or 12-digits without dashes."
+2 QUIT
POSTHELP ;Extended help for 'Okay to post?'
+1 WRITE !?5,"Enter YES to update the balances in the pharmacy location and DRUG file",!?5,"and add a transaction."
+2 WRITE !?5,"Enter NO to abort receiving the drug."
+3 QUIT
PRICEHLP ;Extended help for 'Price per order unit'
+1 WRITE !?5,"Enter the cost for each order unit."
+2 QUIT
QTYHELP ;
+1 WRITE !?5,"The quantity entered will be multiplied by the dispense units",!?5,"per order unit to determine the number of dispense units received."
+2 QUIT
