- PSDEXGS1 ;BIR/JPW - Enter Existing GS (cont'd) ;22 Jun 93
- ;;3.0;CONTROLLED SUBSTANCES ;**33,66,79**;13 Feb 97;Build 20
- ;Reference to ^PSD(58.8 are covered by DBIA #2711
- ;Reference to ^PSD(58.81 are covered by DBIA #2808
- EN ;create order,transaction
- W !!,"Creating entries in the CS files..."
- DIE ;create the order request
- F L +^PSD(58.8,NAOU,1,PSDRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- S:'$D(^PSD(58.8,NAOU,1,PSDRG,3,0)) ^(0)="^58.800118A^^"
- DIE2 S PSDRN=$P(^PSD(58.8,NAOU,1,PSDRG,3,0),"^",3)+1 I $D(^PSD(58.8,NAOU,1,PSDRG,3,PSDRN)) S $P(^PSD(58.8,NAOU,1,PSDRG,3,0),"^",3)=$P(^PSD(58.8,NAOU,1,PSDRG,3,0),"^",3)+1 G DIE2
- K DA,DIC,DIE,DD,DR,DO S DIC(0)="L",(DIC,DIE)="^PSD(58.8,"_NAOU_",1,"_PSDRG_",3,",DA(2)=NAOU,DA(1)=PSDRG,(X,DINUM)=PSDRN D FILE^DICN K DIC
- D NOW^%DTC S PSDT=+$E(%,1,12) W "processing now..."
- S DA=PSDRN,DA(1)=PSDRG,DA(2)=NAOU
- S DR="2////"_+PSDS_";4////"_PHARM_";5///"_QTY_";6////"_NURS_";7///"_MFG_";8///"_LOT_";9///"_EXP_";14///"_RDATE_";16///"_PSDPN_";19///"_QTY_";20///"_QTY_";10////4" D ^DIE K DIE,DR
- L -^PSD(58.8,NAOU,1,PSDRG,0)
- W "transaction history..."
- ADD ;find entry number
- F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- FIND S PSDA=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDA)) S $P(^PSD(58.81,0),"^",3)=PSDA G FIND
- K DA,DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDA D ^DIC K DIC,DLAYGO
- L -^PSD(58.81,0)
- TRANS ;add trans fields
- W !!,"Still updating..."
- K DA,DIE,DR S DA=PSDA,DIE=58.81
- S DR="1////12;2////"_+PSDS_";4////"_PSDRG_";3///"_PSDT_";Q;5////"_QTY_";12///"_MFG_";13///"_LOT_";14///"_EXP_";16///"_PSDPN_";17////"_NAOU_";18////"_PHARM_";20////"_NURS_";19///"_RDATE_";27////"_QTY_";40////"_PSDRN_";10////4;100////1"
- ;DAVE B (PSD*3*33) Add field 103 to DIE call
- S DR=DR_";103////"_PNT10
- D ^DIE K DA,DIE,DR W "vault activity..."
- VAULT ;
- S:'$D(^PSD(58.8,+PSDS,1,PSDRG,4,0)) ^(0)="^58.800119PA^^"
- I '$D(^PSD(58.8,+PSDS,1,PSDRG,4,PSDA,0)) K DA,DIC,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_+PSDS_",1,"_PSDRG_",4,",DA(2)=+PSDS,DA(1)=PSDRG,(X,DINUM)=PSDA D FILE^DICN K DA,DIC
- W "done.",!!
- S $P(^PSD(58.8,NAOU,1,PSDRG,3,PSDRN,0),"^",17)=PSDA
- W !!,"Press <RET> to continue" R X:DTIME W @IOF
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDEXGS1 2203 printed Feb 18, 2025@23:12:22 Page 2
- PSDEXGS1 ;BIR/JPW - Enter Existing GS (cont'd) ;22 Jun 93
- +1 ;;3.0;CONTROLLED SUBSTANCES ;**33,66,79**;13 Feb 97;Build 20
- +2 ;Reference to ^PSD(58.8 are covered by DBIA #2711
- +3 ;Reference to ^PSD(58.81 are covered by DBIA #2808
- EN ;create order,transaction
- +1 WRITE !!,"Creating entries in the CS files..."
- DIE ;create the order request
- +1 FOR
- LOCK +^PSD(58.8,NAOU,1,PSDRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +2 if '$DATA(^PSD(58.8,NAOU,1,PSDRG,3,0))
- SET ^(0)="^58.800118A^^"
- DIE2 SET PSDRN=$PIECE(^PSD(58.8,NAOU,1,PSDRG,3,0),"^",3)+1
- IF $DATA(^PSD(58.8,NAOU,1,PSDRG,3,PSDRN))
- SET $PIECE(^PSD(58.8,NAOU,1,PSDRG,3,0),"^",3)=$PIECE(^PSD(58.8,NAOU,1,PSDRG,3,0),"^",3)+1
- GOTO DIE2
- +1 KILL DA,DIC,DIE,DD,DR,DO
- SET DIC(0)="L"
- SET (DIC,DIE)="^PSD(58.8,"_NAOU_",1,"_PSDRG_",3,"
- SET DA(2)=NAOU
- SET DA(1)=PSDRG
- SET (X,DINUM)=PSDRN
- DO FILE^DICN
- KILL DIC
- +2 DO NOW^%DTC
- SET PSDT=+$EXTRACT(%,1,12)
- WRITE "processing now..."
- +3 SET DA=PSDRN
- SET DA(1)=PSDRG
- SET DA(2)=NAOU
- +4 SET DR="2////"_+PSDS_";4////"_PHARM_";5///"_QTY_";6////"_NURS_";7///"_MFG_";8///"_LOT_";9///"_EXP_";14///"_RDATE_";16///"_PSDPN_";19///"_QTY_";20///"_QTY_";10////4"
- DO ^DIE
- KILL DIE,DR
- +5 LOCK -^PSD(58.8,NAOU,1,PSDRG,0)
- +6 WRITE "transaction history..."
- ADD ;find entry number
- +1 FOR
- LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- FIND SET PSDA=$PIECE(^PSD(58.81,0),"^",3)+1
- IF $DATA(^PSD(58.81,PSDA))
- SET $PIECE(^PSD(58.81,0),"^",3)=PSDA
- GOTO FIND
- +1 KILL DA,DIC,DLAYGO
- SET DIC(0)="L"
- SET (DIC,DLAYGO)=58.81
- SET (X,DINUM)=PSDA
- DO ^DIC
- KILL DIC,DLAYGO
- +2 LOCK -^PSD(58.81,0)
- TRANS ;add trans fields
- +1 WRITE !!,"Still updating..."
- +2 KILL DA,DIE,DR
- SET DA=PSDA
- SET DIE=58.81
- +3 SET DR="1////12;2////"_+PSDS_";4////"_PSDRG_";3///"_PSDT_";Q;5////"_QTY_";12///"_MFG_";13///"_LOT_";14///"_EXP_";16///"_PSDPN_";17////"_NAOU_";18////"_PHARM_";20////"_NURS_";19///"_RDATE_";27////"_QTY_";40////"_PSDRN_";10////4;100////1"
- +4 ;DAVE B (PSD*3*33) Add field 103 to DIE call
- +5 SET DR=DR_";103////"_PNT10
- +6 DO ^DIE
- KILL DA,DIE,DR
- WRITE "vault activity..."
- VAULT ;
- +1 if '$DATA(^PSD(58.8,+PSDS,1,PSDRG,4,0))
- SET ^(0)="^58.800119PA^^"
- +2 IF '$DATA(^PSD(58.8,+PSDS,1,PSDRG,4,PSDA,0))
- KILL DA,DIC,DD,DO
- SET DIC(0)="L"
- SET DIC="^PSD(58.8,"_+PSDS_",1,"_PSDRG_",4,"
- SET DA(2)=+PSDS
- SET DA(1)=PSDRG
- SET (X,DINUM)=PSDA
- DO FILE^DICN
- KILL DA,DIC
- +3 WRITE "done.",!!
- +4 SET $PIECE(^PSD(58.8,NAOU,1,PSDRG,3,PSDRN,0),"^",17)=PSDA
- +5 WRITE !!,"Press <RET> to continue"
- READ X:DTIME
- WRITE @IOF
- +6 QUIT