- PSDRFX ;B'ham ISC/JPW,LTL,BJW - File Dispensing Info ; 14 May 98
- ;;3.0; CONTROLLED SUBSTANCES ;**7,66**;13 Feb 97;Build 3
- ;inserted line 15 to save date return for activity rpt
- UPDAT I $G(PSDPN) F JJ=0:0 S JJ=$O(^PSD(58.8,"F",PSDPN,NAOU,PSDR,JJ)) Q:'JJ S ORD=+JJ
- ;$S(WQTY:18,CQTY:9,1:17) S:PSDTYP=9 QTY=CQTY-OQTY
- W ?40,"Recording transaction... "
- D UPDATE W "done."
- END ;kill variables
- K %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,LQTY,NAOUN,NODE,NUR2,OK,ORD
- K PSD,PSDER,PSDREC,PSDRN,PSDT,PSDTN,QTY,WQTY,X,Y
- Q
- UPDATE ;update 58.8 and 58.81
- ;updating drug balance in 58.8
- F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- D NOW^%DTC S (PSDTN,PSDT)=+%
- S BAL=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)+WQTY
- L -^PSD(58.8,NAOU,1,PSDR,0)
- S $P(^PSD(58.81,+PSDA(1),3),"^")=$G(PSDRET)
- S $P(^PSD(58.81,+PSDA(1),3),U,2)=$P($G(^(3)),U,2)+WQTY K WQTY
- S $P(^PSD(58.81,+PSDA(1),3),U,3)=$G(PSDRE(1)) G EDIT
- ;update order balance
- I $G(ORD),$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),PSDTYP'=9 S $P(^(0),"^",22)=$P(^(0),"^",22)-PSDQ,DA=+$P(^(0),"^",17) D:$P(^(0),"^",22)=0 K DA,DIE,DR
- .K DIE,DR S DIE="^PSD(58.81,",DR="10////12;11////1" D ^DIE K DA,DIE,DR
- .K DA,DIE,DR S DIE="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,",DA=+ORD,DA(1)=+PSDR,DA(2)=+NAOU,DR="10////12;11////1" D ^DIE K DA,DIE,DR
- ADD ;find entry number in 58.81
- 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 DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDREC D ^DIC K DIC,DLAYGO
- L -^PSD(58.81,0)
- EDIT ;edit transaction in 58.81
- S $P(^PSD(58.81,PSDA(1),0),U,16)=$G(PSDRE)
- S $P(^PSD(58.81,PSDA(1),0),U,6)=$S($G(WQTY)&('$G(PSDQ(1))):PSDQ+WQTY,'$G(PSDQ(2)):PSDQ,1:OQTY-$G(PSDQ(2)))
- S:$G(WQTY) $P(^PSD(58.81,PSDA(1),9),U,4)=WQTY
- S $P(^PSD(58.81,PSDA(1),9),U,6)=$G(NUR2)
- K DA,DIK S DA=PSDA(1),DIK="^PSD(58.81," D IX^DIK K DA,DIK
- ;I PSDTYP'=17 D ERR
- Q
- ERR ;err log update
- F L +^PSD(58.89,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- FIND9 S PSDER=$P(^PSD(58.89,0),"^",3)+1 I $D(^PSD(58.89,PSDER)) S $P(^PSD(58.89,0),"^",3)=PSDER G FIND9
- K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.89,(X,DINUM)=PSDER D ^DIC K DIC,DLAYGO
- L -^PSD(58.89,0)
- EDIT9 ;edit error log
- K DA,DIE,DR S DA=PSDER,DIE=58.89,DR="1////"_PSDREC_";2////"_PSDT_";6////"_NAOU D ^DIE K DA,DIE,DR
- S PHARM1=NUR1,QTY=PSDQ
- S:$G(NAOUN)']"" NAOUN=$P($G(^PSD(58.8,NAOU,0)),U) D ^PSDRFM
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDRFX 2522 printed Mar 13, 2025@20:53:26 Page 2
- PSDRFX ;B'ham ISC/JPW,LTL,BJW - File Dispensing Info ; 14 May 98
- +1 ;;3.0; CONTROLLED SUBSTANCES ;**7,66**;13 Feb 97;Build 3
- +2 ;inserted line 15 to save date return for activity rpt
- UPDAT IF $GET(PSDPN)
- FOR JJ=0:0
- SET JJ=$ORDER(^PSD(58.8,"F",PSDPN,NAOU,PSDR,JJ))
- if 'JJ
- QUIT
- SET ORD=+JJ
- +1 ;$S(WQTY:18,CQTY:9,1:17) S:PSDTYP=9 QTY=CQTY-OQTY
- +2 WRITE ?40,"Recording transaction... "
- +3 DO UPDATE
- WRITE "done."
- END ;kill variables
- +1 KILL %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,LQTY,NAOUN,NODE,NUR2,OK,ORD
- +2 KILL PSD,PSDER,PSDREC,PSDRN,PSDT,PSDTN,QTY,WQTY,X,Y
- +3 QUIT
- UPDATE ;update 58.8 and 58.81
- +1 ;updating drug balance in 58.8
- +2 FOR
- LOCK +^PSD(58.8,NAOU,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +3 DO NOW^%DTC
- SET (PSDTN,PSDT)=+%
- +4 SET BAL=$PIECE(^PSD(58.8,NAOU,1,PSDR,0),"^",4)
- SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+WQTY
- +5 LOCK -^PSD(58.8,NAOU,1,PSDR,0)
- +6 SET $PIECE(^PSD(58.81,+PSDA(1),3),"^")=$GET(PSDRET)
- +7 SET $PIECE(^PSD(58.81,+PSDA(1),3),U,2)=$PIECE($GET(^(3)),U,2)+WQTY
- KILL WQTY
- +8 SET $PIECE(^PSD(58.81,+PSDA(1),3),U,3)=$GET(PSDRE(1))
- GOTO EDIT
- +9 ;update order balance
- +10 IF $GET(ORD)
- IF $DATA(^PSD(58.8,NAOU,1,PSDR,3,ORD,0))
- IF PSDTYP'=9
- SET $PIECE(^(0),"^",22)=$PIECE(^(0),"^",22)-PSDQ
- SET DA=+$PIECE(^(0),"^",17)
- if $PIECE(^(0),"^",22)=0
- Begin DoDot:1
- +11 KILL DIE,DR
- SET DIE="^PSD(58.81,"
- SET DR="10////12;11////1"
- DO ^DIE
- KILL DA,DIE,DR
- +12 KILL DA,DIE,DR
- SET DIE="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,"
- SET DA=+ORD
- SET DA(1)=+PSDR
- SET DA(2)=+NAOU
- SET DR="10////12;11////1"
- DO ^DIE
- KILL DA,DIE,DR
- End DoDot:1
- KILL DA,DIE,DR
- ADD ;find entry number in 58.81
- +1 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 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)
- EDIT ;edit transaction in 58.81
- +1 SET $PIECE(^PSD(58.81,PSDA(1),0),U,16)=$GET(PSDRE)
- +2 SET $PIECE(^PSD(58.81,PSDA(1),0),U,6)=$SELECT($GET(WQTY)&('$GET(PSDQ(1))):PSDQ+WQTY,'$GET(PSDQ(2)):PSDQ,1:OQTY-$GET(PSDQ(2)))
- +3 if $GET(WQTY)
- SET $PIECE(^PSD(58.81,PSDA(1),9),U,4)=WQTY
- +4 SET $PIECE(^PSD(58.81,PSDA(1),9),U,6)=$GET(NUR2)
- +5 KILL DA,DIK
- SET DA=PSDA(1)
- SET DIK="^PSD(58.81,"
- DO IX^DIK
- KILL DA,DIK
- +6 ;I PSDTYP'=17 D ERR
- +7 QUIT
- ERR ;err log update
- +1 FOR
- LOCK +^PSD(58.89,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- FIND9 SET PSDER=$PIECE(^PSD(58.89,0),"^",3)+1
- IF $DATA(^PSD(58.89,PSDER))
- SET $PIECE(^PSD(58.89,0),"^",3)=PSDER
- GOTO FIND9
- +1 KILL DIC,DLAYGO
- SET DIC(0)="L"
- SET (DIC,DLAYGO)=58.89
- SET (X,DINUM)=PSDER
- DO ^DIC
- KILL DIC,DLAYGO
- +2 LOCK -^PSD(58.89,0)
- EDIT9 ;edit error log
- +1 KILL DA,DIE,DR
- SET DA=PSDER
- SET DIE=58.89
- SET DR="1////"_PSDREC_";2////"_PSDT_";6////"_NAOU
- DO ^DIE
- KILL DA,DIE,DR
- +2 SET PHARM1=NUR1
- SET QTY=PSDQ
- +3 if $GET(NAOUN)']""
- SET NAOUN=$PIECE($GET(^PSD(58.8,NAOU,0)),U)
- DO ^PSDRFM
- +4 QUIT
