Routine: PSAREC

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

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)

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

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."

INV ;Extended help for 'Invoice number'

 W !?5,"Enter the invoice number for the receipts."

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."

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."

PRICEHLP ;Extended help for 'Price per order unit'

 W !?5,"Enter the cost for each order unit."

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."

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

PSAREC.m