PSDOPT1 ;BIR/JPW,LTL - Outpatient Rx Entry (cont'd) ;20 July 94
;;3.0;CONTROLLED SUBSTANCES;**30,66,71,88**;13 Feb 97;Build 1
;Reference to PS(52.5 supported by DBIA #786
;References to ^PSD(58.8 are covered by DBIA #2711
;References to file 58.81 are covered by DBIA #2808
;Reference to PSRX( supported by DBIA #986
;Reference to routine PSOCSRL supported by DBIA #983
UPDATE W !!,"Creating an Outpatient Transaction..."
F L +^PSD(58.8,+PSDS,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D NOW^%DTC S PSDT=+% 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)
W "updating..."
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,DLAYGO)=58.81,DIC(0)="L",(X,DINUM)=PSDA D ^DIC K DIC,DLAYGO
L -^PSD(58.81,0)
ADD ;set trans
S ^PSD(58.81,PSDA,0)=PSDA_"^6^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_QTY_"^"_PSDUZ_"^^^"_BAL
S ^PSD(58.81,PSDA,6)=PSDRX_"^"_$S($G(NEW(1)):NEW(1),1:"")_"^"_DAT_"^"_$S($G(NEW(2)):NEW(2),1:"")_"^"_RXNUM_"^"_PSDRPH
S ^PSD(58.81,PSDA,"CS")=1
S DIK="^PSD(58.81,",DA=PSDA D IX^DIK K DA,DIK
W "vault activity..."
DIE I '$D(^PSD(58.8,+PSDS,1,PSDR,4,0)) S ^(0)="^58.800119PA^^"
K DA,DIC,DD,DO S DA(1)=PSDR,DA(2)=+PSDS,(X,DINUM)=PSDA,DIC(0)="L",DIC="^PSD(58.8,"_+PSDS_",1,"_PSDR_",4," D FILE^DICN K DIC,DINUM
;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 DA,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 DA,DIC,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
W "done."
;check if user has access to release
D CHKEY^PSDOPT I $G(PSDOUT) Q
;PSD*3*30 (Dave B) Check for already released
I $G(PSDREL)'="" Q
I $G(PSDRTS)=1 K PSDRTS Q
PSDREL S X="PSOCSRL" X ^%ZOSF("TEST") I $T S XTYPE=$S($G(NEW(2)):"P"_U_NEW(2),$G(NEW(1)):1_U_NEW(1),1:"") D EN^PSOCSRL(PSDRX,XTYPE,PSDRPH)
Q
;
PSDRTS ;Returned to stock continued
W !,"Updating balances"
F L +^PSD(58.8,+PSDS,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D NOW^%DTC S PSDT=+%,BAL=+$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4),$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)=$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)+PSDQTY
L -^PSD(58.8,+PSDS,1,PSDR,0) W "."
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND1 S PSDA=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDA)) S $P(^PSD(58.81,0),"^",3)=PSDA G FIND1
K DA,DIC,DLAYGO S (DIC,DLAYGO)=58.81,DIC(0)="L",(X,DINUM)=PSDA D ^DIC K DIC,DLAYGO
L -^PSD(58.81,0)
S ^PSD(58.81,PSDA,0)=PSDA_"^3^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_PSDQTY_"^"_PSDUZ_"^^^"_BAL
S ^PSD(58.81,PSDA,3)=PSDT_"^"_PSDQTY_"^"_"Returned by Outpatient"
S ^PSD(58.81,PSDA,"CS")=1
S ^PSD(58.81,PSDA,6)=PSDRX_"^"_$S($G(PSDFILL)="R":PSDNUM1,1:"")_"^"_DAT_"^"_$S($G(PSDFILL)="P":PSDNUM1,1:"")_"^"_RXNUM_"^"_PSDRPH
S PSDRTS=1,QTY=-PSDQTY D DIE
Q
;
PSDORIG ;Check original labels
;Check for suspense
I +$P($G(^PSRX(PSDRX,2)),U,2)'<PSDOIN S PSDRXFD=$P(^(2),U,2) D
.S PSDSUPN=$O(^PS(52.5,"B",PSDRX,0))
.I PSDSUPN,$D(^PS(52.5,"C",PSDRXFD,PSDSUPN)),$G(^PS(52.5,PSDSUPN,"P"))'=1 W !!,"Original suspended." S PSDRX(1)="",PSDOUT=1 Q
.K PSDLBL D VER^PSDOPT
.I $G(PSOVR) F PSDLBL=0:0 S PSDLBL=$O(^PSRX(PSDRX,"L",PSDLBL)) Q:'PSDLBL I '+$P($G(^PSRX(PSDRX,"L",PSDLBL,0)),"^",2),'$P($G(^(0)),"^",5) S PSDLBL(1)=1
.I '$G(PSOVR) F PSDLBL=0:0 S PSDLBL=$O(^PSRX(PSDRX,"L",PSDLBL)) Q:'PSDLBL I '+$P($G(^PSRX(PSDRX,"L",PSDLBL,0)),"^",2),$P($G(^(0)),"^",5)'["INTERACTION" S PSDLBL(1)=1
.K PSOVR,PSDERR,PSDSTA,PSDRXIN I '$G(PSDLBL(1)) S PSDRX(1)="",PSDOUT=1 W !!,"Original label not printed." Q
Q
PSDRFL ;Check refill labels
I $D(^PSRX(PSDRX,1,PSDFLNO,0)),'$P(^(0),U,16),$P($G(^(0)),U)'<PSDOIN D
.F PSDLBL=0:0 S PSDLBL=$O(^PSRX(PSDRX,"L",PSDLBL)) Q:'PSDLBL I $P(^PSRX(PSDRX,"L",PSDLBL,0),U,2)=PSDFLNO S PSDLBL(1)=1
.I '$G(PSDLBL(1)) W !!,"Refill #",PSDFLNO," label not printed." S PSDOUT=1,PSDRX(1)="" Q
Q
PSDPRTL ;Chec partial labels
I $D(^PSRX(PSDRX,"P",PSDFLNO,0)),'$P(^(0),U,16),$P($G(^(0)),U)'<PSDOIN D
.F PSDLBL=0:0 S PSDLBL=$O(^PSRX(PSDRX,"L",PSDLBL)) Q:'PSDLBL I $P(^PSRX(PSDRX,"L",0),U,2)=99-PSDFLNO S PSDLBL(1)=1
.I '$G(PSDLBL(1)) W !!,"Partial #",PSDFLNO," label not printed." S PSDOUT=1,PSDRX(1)="" Q
Q
RTSMUL ; Setup local array of refills in reverse order
S PSD1=0 F S PSD1=$O(^PSD(58.81,"AOP",PSDRX,PSD1)) Q:PSD1'>0 S DATA6=$G(^PSD(58.81,PSD1,6)) D
.S PSDXXX=PSD1
.S PSD1MUL=PSD1*-1
.S PSDMUL(PSD1MUL)=$P(DATA6,"^",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDOPT1 4756 printed Apr 09, 2024@20:50:14 Page 2
PSDOPT1 ;BIR/JPW,LTL - Outpatient Rx Entry (cont'd) ;20 July 94
+1 ;;3.0;CONTROLLED SUBSTANCES;**30,66,71,88**;13 Feb 97;Build 1
+2 ;Reference to PS(52.5 supported by DBIA #786
+3 ;References to ^PSD(58.8 are covered by DBIA #2711
+4 ;References to file 58.81 are covered by DBIA #2808
+5 ;Reference to PSRX( supported by DBIA #986
+6 ;Reference to routine PSOCSRL supported by DBIA #983
UPDATE WRITE !!,"Creating an Outpatient Transaction..."
+1 FOR
LOCK +^PSD(58.8,+PSDS,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+2 DO NOW^%DTC
SET PSDT=+%
SET BAL=+$PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)-QTY
+3 LOCK -^PSD(58.8,+PSDS,1,PSDR,0)
+4 WRITE "updating..."
+5 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,DLAYGO)=58.81
SET DIC(0)="L"
SET (X,DINUM)=PSDA
DO ^DIC
KILL DIC,DLAYGO
+2 LOCK -^PSD(58.81,0)
ADD ;set trans
+1 SET ^PSD(58.81,PSDA,0)=PSDA_"^6^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_QTY_"^"_PSDUZ_"^^^"_BAL
+2 SET ^PSD(58.81,PSDA,6)=PSDRX_"^"_$SELECT($GET(NEW(1)):NEW(1),1:"")_"^"_DAT_"^"_$SELECT($GET(NEW(2)):NEW(2),1:"")_"^"_RXNUM_"^"_PSDRPH
+3 SET ^PSD(58.81,PSDA,"CS")=1
+4 SET DIK="^PSD(58.81,"
SET DA=PSDA
DO IX^DIK
KILL DA,DIK
+5 WRITE "vault activity..."
DIE IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,4,0))
SET ^(0)="^58.800119PA^^"
+1 KILL DA,DIC,DD,DO
SET DA(1)=PSDR
SET DA(2)=+PSDS
SET (X,DINUM)=PSDA
SET DIC(0)="L"
SET DIC="^PSD(58.8,"_+PSDS_",1,"_PSDR_",4,"
DO FILE^DICN
KILL DIC,DINUM
+2 ;monthly activity
+3 IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,5,0))
SET ^(0)="^58.801A^^"
+4 IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,5,$EXTRACT(DT,1,5)*100,0))
KILL DA,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 DA,DIC,DINUM,DLAYGO
+5 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
+6 WRITE "done."
+7 ;check if user has access to release
+8 DO CHKEY^PSDOPT
IF $GET(PSDOUT)
QUIT
+9 ;PSD*3*30 (Dave B) Check for already released
+10 IF $GET(PSDREL)'=""
QUIT
+11 IF $GET(PSDRTS)=1
KILL PSDRTS
QUIT
PSDREL SET X="PSOCSRL"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET XTYPE=$SELECT($GET(NEW(2)):"P"_U_NEW(2),$GET(NEW(1)):1_U_NEW(1),1:"")
DO EN^PSOCSRL(PSDRX,XTYPE,PSDRPH)
+1 QUIT
+2 ;
PSDRTS ;Returned to stock continued
+1 WRITE !,"Updating balances"
+2 FOR
LOCK +^PSD(58.8,+PSDS,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+3 DO NOW^%DTC
SET PSDT=+%
SET BAL=+$PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)
SET $PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)=$PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)+PSDQTY
+4 LOCK -^PSD(58.8,+PSDS,1,PSDR,0)
WRITE "."
+5 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND1 SET PSDA=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSDA))
SET $PIECE(^PSD(58.81,0),"^",3)=PSDA
GOTO FIND1
+1 KILL DA,DIC,DLAYGO
SET (DIC,DLAYGO)=58.81
SET DIC(0)="L"
SET (X,DINUM)=PSDA
DO ^DIC
KILL DIC,DLAYGO
+2 LOCK -^PSD(58.81,0)
+3 SET ^PSD(58.81,PSDA,0)=PSDA_"^3^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_PSDQTY_"^"_PSDUZ_"^^^"_BAL
+4 SET ^PSD(58.81,PSDA,3)=PSDT_"^"_PSDQTY_"^"_"Returned by Outpatient"
+5 SET ^PSD(58.81,PSDA,"CS")=1
+6 SET ^PSD(58.81,PSDA,6)=PSDRX_"^"_$SELECT($GET(PSDFILL)="R":PSDNUM1,1:"")_"^"_DAT_"^"_$SELECT($GET(PSDFILL)="P":PSDNUM1,1:"")_"^"_RXNUM_"^"_PSDRPH
+7 SET PSDRTS=1
SET QTY=-PSDQTY
DO DIE
+8 QUIT
+9 ;
PSDORIG ;Check original labels
+1 ;Check for suspense
+2 IF +$PIECE($GET(^PSRX(PSDRX,2)),U,2)'<PSDOIN
SET PSDRXFD=$PIECE(^(2),U,2)
Begin DoDot:1
+3 SET PSDSUPN=$ORDER(^PS(52.5,"B",PSDRX,0))
+4 IF PSDSUPN
IF $DATA(^PS(52.5,"C",PSDRXFD,PSDSUPN))
IF $GET(^PS(52.5,PSDSUPN,"P"))'=1
WRITE !!,"Original suspended."
SET PSDRX(1)=""
SET PSDOUT=1
QUIT
+5 KILL PSDLBL
DO VER^PSDOPT
+6 IF $GET(PSOVR)
FOR PSDLBL=0:0
SET PSDLBL=$ORDER(^PSRX(PSDRX,"L",PSDLBL))
if 'PSDLBL
QUIT
IF '+$PIECE($GET(^PSRX(PSDRX,"L",PSDLBL,0)),"^",2)
IF '$PIECE($GET(^(0)),"^",5)
SET PSDLBL(1)=1
+7 IF '$GET(PSOVR)
FOR PSDLBL=0:0
SET PSDLBL=$ORDER(^PSRX(PSDRX,"L",PSDLBL))
if 'PSDLBL
QUIT
IF '+$PIECE($GET(^PSRX(PSDRX,"L",PSDLBL,0)),"^",2)
IF $PIECE($GET(^(0)),"^",5)'["INTERACTION"
SET PSDLBL(1)=1
+8 KILL PSOVR,PSDERR,PSDSTA,PSDRXIN
IF '$GET(PSDLBL(1))
SET PSDRX(1)=""
SET PSDOUT=1
WRITE !!,"Original label not printed."
QUIT
End DoDot:1
+9 QUIT
PSDRFL ;Check refill labels
+1 IF $DATA(^PSRX(PSDRX,1,PSDFLNO,0))
IF '$PIECE(^(0),U,16)
IF $PIECE($GET(^(0)),U)'<PSDOIN
Begin DoDot:1
+2 FOR PSDLBL=0:0
SET PSDLBL=$ORDER(^PSRX(PSDRX,"L",PSDLBL))
if 'PSDLBL
QUIT
IF $PIECE(^PSRX(PSDRX,"L",PSDLBL,0),U,2)=PSDFLNO
SET PSDLBL(1)=1
+3 IF '$GET(PSDLBL(1))
WRITE !!,"Refill #",PSDFLNO," label not printed."
SET PSDOUT=1
SET PSDRX(1)=""
QUIT
End DoDot:1
+4 QUIT
PSDPRTL ;Chec partial labels
+1 IF $DATA(^PSRX(PSDRX,"P",PSDFLNO,0))
IF '$PIECE(^(0),U,16)
IF $PIECE($GET(^(0)),U)'<PSDOIN
Begin DoDot:1
+2 FOR PSDLBL=0:0
SET PSDLBL=$ORDER(^PSRX(PSDRX,"L",PSDLBL))
if 'PSDLBL
QUIT
IF $PIECE(^PSRX(PSDRX,"L",0),U,2)=99-PSDFLNO
SET PSDLBL(1)=1
+3 IF '$GET(PSDLBL(1))
WRITE !!,"Partial #",PSDFLNO," label not printed."
SET PSDOUT=1
SET PSDRX(1)=""
QUIT
End DoDot:1
+4 QUIT
RTSMUL ; Setup local array of refills in reverse order
+1 SET PSD1=0
FOR
SET PSD1=$ORDER(^PSD(58.81,"AOP",PSDRX,PSD1))
if PSD1'>0
QUIT
SET DATA6=$GET(^PSD(58.81,PSD1,6))
Begin DoDot:1
+2 SET PSDXXX=PSD1
+3 SET PSD1MUL=PSD1*-1
+4 SET PSDMUL(PSD1MUL)=$PIECE(DATA6,"^",2)
End DoDot:1
+5 QUIT
