PSDDFP1.m

PSDDFP1 ;BIR/JPW-Disp from Pharm w/o Green Sheet (cont'd) ; 2 Aug 93

 ;;3.0; CONTROLLED SUBSTANCES ;**16,66**;13 Feb 97;Build 3

 ;

 ;References to ^PSD(58.8, supported by DBIA2711

 ;References to ^PSD(58.81 are supported by DBIA2808

TRANS ;create a disp transaction

 W !!,"Creating a dispensing transaction..."

 F  L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q

FIND S PSDREC=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDREC)) S $P(^PSD(58.81,0),"^",3)=PSDREC G FIND

 K DA,DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDREC D ^DIC K DIC,DLAYGO

 L -^PSD(58.81,0)

ADD ;add info to your vault (58.8)

 W "vault activity" S:'$D(^PSD(58.8,PSDS,1,PSDR,4,0)) ^(0)="^58.800119PA^^"

 K DA,DIC,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_PSDS_",1,"_PSDR_",4,",DA(2)=PSDS,DA(1)=PSDR,(X,DINUM)=PSDREC D FILE^DICN K DIC,DD,DO

 ;monthly activity

 I '$D(^PSD(58.8,PSDS,1,PSDR,5,0)) S ^(0)="^58.801A^^"

 I '$D(^PSD(58.8,PSDS,1,PSDR,5,$E(DT,1,5)*100,0)) K DIC S DIC="^PSD(58.8,"_PSDS_",1,"_PSDR_",5,",DIC(0)="LM",DLAYGO=58.8,(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSDS,DA(1)=PSDR D ^DIC K DIC,DA,DINUM,DLAYGO

 K DA,DIE,DR S DIE="^PSD(58.8,"_PSDS_",1,"_PSDR_",5,",DA(2)=PSDS,DA(1)=PSDR,DA=$E(DT,1,5)*100,DR="9////^S X=$P($G(^(0)),""^"",6)+QTY" D ^DIE K DA,DIE,DR

UPDATE ;update transaction with activity # from 58.8

 W !!,?5,"Updating on-hand quantity..."

 ;

 ;DAVE B (PSD*3*16 -28APR99) Removed lock, because it is now

 ;in routine PSDDFP where the user selects the drug.

 ;F  L +^PSD(58.8,PSDS,1,PSDR,0):0 I  Q

 D NOW^%DTC S PSDDT=+%

 S BAL=$P(^PSD(58.8,PSDS,1,PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)-QTY

 L -^PSD(58.8,PSDS,1,PSDR,0) S $P(^PSD(58.81,PSDREC,0),"^",10)=BAL W "done.",!

 W !!,"Old Balance : ",BAL,?35,"New Balance: ",BAL-QTY

 W !!,"Updating your transaction history..."

 K DA,DIE,DR S DA=PSDREC,DIE=58.81

 S DR="1////2;2////"_PSDS_";4////"_PSDR_";3////"_PSDDT_";5////"_QTY_";9////"_BAL_";6////"_PSDUZ_";17////"_NAOU_";100////1" D ^DIE

 I ASK W "still updating..." K DR S DR="12///"_MFG_";13///"_LOT_";14///"_EXP D ^DIE

 K DA,DIE,DR W "done.",!!

END Q

PSDDFP1   ;BIR/JPW-Disp from Pharm w/o Green Sheet (cont'd) ; 2 Aug 93

 +1       ;;3.0; CONTROLLED SUBSTANCES ;**16,66**;13 Feb 97;Build 3

 +2       ;

 +3       ;References to ^PSD(58.8, supported by DBIA2711

 +4       ;References to ^PSD(58.81 are supported by DBIA2808

TRANS     ;create a disp transaction

 +1        WRITE !!,"Creating a dispensing transaction..."

 +2        FOR 

               LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)

              IF $TEST

                   QUIT 

FIND       SET PSDREC=$PIECE(^PSD(58.81,0),"^",3)+1

           IF $DATA(^PSD(58.81,PSDREC))

               SET $PIECE(^PSD(58.81,0),"^",3)=PSDREC

               GOTO FIND

 +1        KILL DA,DIC,DLAYGO

           SET DIC(0)="L"

           SET (DIC,DLAYGO)=58.81

           SET (X,DINUM)=PSDREC

           DO ^DIC

           KILL DIC,DLAYGO

 +2        LOCK -^PSD(58.81,0)

ADD       ;add info to your vault (58.8)

 +1        WRITE "vault activity"

           IF '$DATA(^PSD(58.8,PSDS,1,PSDR,4,0))

               SET ^(0)="^58.800119PA^^"

 +2        KILL DA,DIC,DD,DO

           SET DIC(0)="L"

           SET DIC="^PSD(58.8,"_PSDS_",1,"_PSDR_",4,"

           SET DA(2)=PSDS

           SET DA(1)=PSDR

           SET (X,DINUM)=PSDREC

           DO FILE^DICN

           KILL DIC,DD,DO

 +3       ;monthly activity

 +4        IF '$DATA(^PSD(58.8,PSDS,1,PSDR,5,0))

               SET ^(0)="^58.801A^^"

 +5        IF '$DATA(^PSD(58.8,PSDS,1,PSDR,5,$EXTRACT(DT,1,5)*100,0))

               KILL DIC

               SET DIC="^PSD(58.8,"_PSDS_",1,"_PSDR_",5,"

               SET DIC(0)="LM"

               SET DLAYGO=58.8

               SET (X,DINUM)=$EXTRACT(DT,1,5)*100

               SET DA(2)=PSDS

               SET DA(1)=PSDR

               DO ^DIC

               KILL DIC,DA,DINUM,DLAYGO

 +6        KILL DA,DIE,DR

           SET DIE="^PSD(58.8,"_PSDS_",1,"_PSDR_",5,"

           SET DA(2)=PSDS

           SET DA(1)=PSDR

           SET DA=$EXTRACT(DT,1,5)*100

           SET DR="9////^S X=$P($G(^(0)),""^"",6)+QTY"

           DO ^DIE

           KILL DA,DIE,DR

UPDATE    ;update transaction with activity # from 58.8

 +1        WRITE !!,?5,"Updating on-hand quantity..."

 +2       ;

 +3       ;DAVE B (PSD*3*16 -28APR99) Removed lock, because it is now

 +4       ;in routine PSDDFP where the user selects the drug.

 +5       ;F  L +^PSD(58.8,PSDS,1,PSDR,0):0 I  Q

 +6        DO NOW^%DTC

           SET PSDDT=+%

 +7        SET BAL=$PIECE(^PSD(58.8,PSDS,1,PSDR,0),"^",4)

           SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)-QTY

 +8        LOCK -^PSD(58.8,PSDS,1,PSDR,0)

           SET $PIECE(^PSD(58.81,PSDREC,0),"^",10)=BAL

           WRITE "done.",!

 +9        WRITE !!,"Old Balance : ",BAL,?35,"New Balance: ",BAL-QTY

 +10       WRITE !!,"Updating your transaction history..."

 +11       KILL DA,DIE,DR

           SET DA=PSDREC

           SET DIE=58.81

 +12       SET DR="1////2;2////"_PSDS_";4////"_PSDR_";3////"_PSDDT_";5////"_QTY_";9////"_BAL_";6////"_PSDUZ_";17////"_NAOU_";100////1"

           DO ^DIE

 +13       IF ASK

               WRITE "still updating..."

               KILL DR

               SET DR="12///"_MFG_";13///"_LOT_";14///"_EXP

               DO ^DIE

 +14       KILL DA,DIE,DR

           WRITE "done.",!!

END        QUIT