- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDDFP1 2087 printed Apr 23, 2025@17:59:59 Page 2
- 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
