- 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 Jan 18, 2025@02:48:32 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