PSONRXN ;IHS/DSD/JCM - GETS NEXT VALID RX NUMBER ;08/09/93 9:17
;;7.0;OUTPATIENT PHARMACY;**5,25,166,268**;DEC 1997;Build 9
;
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^DIC supported by DBIA 10006
;External reference to ^DIE supported by DBIA 10018
;External reference to ^DIR supported by DBIA 10026
;External reference to ^VALM1 supported by DBIA 10016
;External reference to ^DPT( supported by DBIA 10035
;
; This routine asks for the next rx # if manually assigning rx#
; and gets next rx# if auto numbering.
;
;-------------------------------------------------------------------
;
MANUAL ; Entry Point to ask user for new rx #
;
S PSONEW("DFLG")=0
K DIR S DIR(0)="52,.01O"
S DIR("A")="Select New Rx # for "_$S($G(PSORX("NAME"))]"":PSORX("NAME"),1:"")
I $G(PSONEW("RX #"))]"",'$G(COPY) S DIR("B")=PSONEW("RX #")
D DIR^PSODIR2 K DIR,DIC,DIE,DA
I X="" S PSONEW("QFLG")=1 G MANUALX
I "Pp"[Y K Y D ^PSODSPL G MANUAL
I "Rr"[Y K Y S (PSONEW("QFLG"),PSORX("DO REFILL"))=1 G MANUALX
I $G(PSODIR("DFLG"))=1 S (PSONEW("QFLG"),PSORX("QFLG"))=1 G MANUALX
G:$G(PSONEW("FIELD")) MANUALX
S PSOX=Y
;
CHECK ; Entry Point to check if valid new rx number
S:'$D(PSOX) PSOX=$G(PSONEW("RX #"))
S PSONRXN("ERR FLG")=0
S DIC="^PSRX(",DIC(0)="XZ",X=PSOX D ^DIC K DIC
I Y'<0 D G MANUALX
. W $C(7),!!,?10,"Not a new prescription number!!!",!,"Rxn: ",Y(0,0),!,"Patient: ",$S($D(^DPT(+$P(Y(0),"^",2),0)):$P(^(0),"^"),1:"UNKNOWN"),!,"Drug: ",$S($D(^PSDRUG(+$P(Y(0),"^",6),0)):$P(^(0),"^"),1:"UNKNOWN")
. S PSONRXN("ID")=$P(Y(0),"^",13)
. I PSONRXN("ID") W !,"Issued: ",$E(PSONRXN("ID"),4,5),"-",$E(PSONRXN("ID"),6,7),"-",$E(PSONRXN("ID"),2,3)
. K PSONRXN("ID"),Y
. W:$G(PSODRUG("NAME")) !,"RX DELETED",!
. S PSONRXN("ERR FLG")=1
. I $G(PSOFIN)!($G(PSOFINFL)),'$G(PSOAC) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
. Q
L +^PSRX("B",PSOX):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T L -^PSRX("B",PSOX) D G MANUALX
. W $C(7),?10,"Prescription Rx# "_PSOX_" already being processed."
. W:$G(PSODRUG("NAME")) !,"Rx Deleted",!
. S PSONRXN("ERR FLG")=1
. Q
S PSONEW("RX #")=PSOX
MANUALX I $G(PSONRXN("ERR FLG"))=1 S (PSONEW("DFLG"),PSONEW("QFLG"))=1
K PSONRXN,X,Y,DIRUT,DTOUT,DUOUT,DIC,DIE,DR,PSOX,PSODIR,PSOX1
Q
;
AUTO ; Entry point for getting next rx # if autonumbering
S PSONEW("QFLG")=0
S PSONRXN("TYPE")=$S('+$G(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")[2&(+$G(^PS(59,+PSOSITE,2))):3,1:8)
L +^PS(59,+PSOSITE,PSONRXN("TYPE")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
S PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE")),PSONRXN("LO")=$P(PSOX1,"^")
S PSONRXN("HI")=$P(PSOX1,"^",2),PSOI=$P(PSOX1,"^",3),PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI
S:PSOI<PSONRXN("LO") PSOI=PSONRXN("LO")
LOOP2 F S PSOI=PSOI+1 D:PSOI>PSONRXN("HI") FATAL Q:'$D(^PSRX("B",PSOI))!PSONEW("QFLG")
G:PSONEW("QFLG") AUTOX
K DUP L +^PSRX("B",PSOI):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) D I $G(DUP) K DUP,I G LOOP2
.I $D(^PSRX("B",PSOI))!'$T L -^PSRX("B",PSOI) S DUP=1 Q
.F I=65:1:90 I $D(^PSRX("B",PSOI_$C(I))) L -^PSRX("B",PSOI) S DUP=1 Q
K DIC,DIE,DA,DUP,I
S DIE=59,DA=PSOSITE
S DR=$S(PSONRXN("TYPE")=8:"2003////"_PSOI,PSONRXN("TYPE")=3:"1002.1////"_PSOI,1:"2003////"_PSOI)
S PSONEW("RX #")=PSOI
D ^DIE K DIE,DIC,DR,DA
L -^PS(59,+PSOSITE,PSONRXN("TYPE"))
AUTOX K PSOX1,PSONRXN,PSOI,X,Y
Q
;
FATAL ;error in autonum queue if necessary and quit
W !!,$C(7),"Fatal error in Autonumbering - No Numbers Left!",!,"See Application Package Coordinator!",!,$C(7)
S PSONEW("QFLG")=1 S DIR("A")="Enter RETURN to continue" D PAUSE^VALM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSONRXN 3692 printed Apr 09, 2024@21:33:55 Page 2
PSONRXN ;IHS/DSD/JCM - GETS NEXT VALID RX NUMBER ;08/09/93 9:17
+1 ;;7.0;OUTPATIENT PHARMACY;**5,25,166,268**;DEC 1997;Build 9
+2 ;
+3 ;External reference to ^PSDRUG supported by DBIA 221
+4 ;External reference to ^DIC supported by DBIA 10006
+5 ;External reference to ^DIE supported by DBIA 10018
+6 ;External reference to ^DIR supported by DBIA 10026
+7 ;External reference to ^VALM1 supported by DBIA 10016
+8 ;External reference to ^DPT( supported by DBIA 10035
+9 ;
+10 ; This routine asks for the next rx # if manually assigning rx#
+11 ; and gets next rx# if auto numbering.
+12 ;
+13 ;-------------------------------------------------------------------
+14 ;
MANUAL ; Entry Point to ask user for new rx #
+1 ;
+2 SET PSONEW("DFLG")=0
+3 KILL DIR
SET DIR(0)="52,.01O"
+4 SET DIR("A")="Select New Rx # for "_$SELECT($GET(PSORX("NAME"))]"":PSORX("NAME"),1:"")
+5 IF $GET(PSONEW("RX #"))]""
IF '$GET(COPY)
SET DIR("B")=PSONEW("RX #")
+6 DO DIR^PSODIR2
KILL DIR,DIC,DIE,DA
+7 IF X=""
SET PSONEW("QFLG")=1
GOTO MANUALX
+8 IF "Pp"[Y
KILL Y
DO ^PSODSPL
GOTO MANUAL
+9 IF "Rr"[Y
KILL Y
SET (PSONEW("QFLG"),PSORX("DO REFILL"))=1
GOTO MANUALX
+10 IF $GET(PSODIR("DFLG"))=1
SET (PSONEW("QFLG"),PSORX("QFLG"))=1
GOTO MANUALX
+11 if $GET(PSONEW("FIELD"))
GOTO MANUALX
+12 SET PSOX=Y
+13 ;
CHECK ; Entry Point to check if valid new rx number
+1 if '$DATA(PSOX)
SET PSOX=$GET(PSONEW("RX #"))
+2 SET PSONRXN("ERR FLG")=0
+3 SET DIC="^PSRX("
SET DIC(0)="XZ"
SET X=PSOX
DO ^DIC
KILL DIC
+4 IF Y'<0
Begin DoDot:1
+5 WRITE $CHAR(7),!!,?10,"Not a new prescription number!!!",!,"Rxn: ",Y(0,0),!,"Patient: ",$SELECT($DATA(^DPT(+$PIECE(Y(0),"^",2),0)):$PIECE(^(0),"^"),1:"UNKNOWN"),!,"Drug: ",$SELECT($DATA(^PSDRUG(+$PIECE(Y(0),"^",6),0)):$PIECE(^(0),"^"),1
:"UNKNOWN")
+6 SET PSONRXN("ID")=$PIECE(Y(0),"^",13)
+7 IF PSONRXN("ID")
WRITE !,"Issued: ",$EXTRACT(PSONRXN("ID"),4,5),"-",$EXTRACT(PSONRXN("ID"),6,7),"-",$EXTRACT(PSONRXN("ID"),2,3)
+8 KILL PSONRXN("ID"),Y
+9 if $GET(PSODRUG("NAME"))
WRITE !,"RX DELETED",!
+10 SET PSONRXN("ERR FLG")=1
+11 IF $GET(PSOFIN)!($GET(PSOFINFL))
IF '$GET(PSOAC)
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
+12 QUIT
End DoDot:1
GOTO MANUALX
+13 LOCK +^PSRX("B",PSOX):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
LOCK -^PSRX("B",PSOX)
Begin DoDot:1
+14 WRITE $CHAR(7),?10,"Prescription Rx# "_PSOX_" already being processed."
+15 if $GET(PSODRUG("NAME"))
WRITE !,"Rx Deleted",!
+16 SET PSONRXN("ERR FLG")=1
+17 QUIT
End DoDot:1
GOTO MANUALX
+18 SET PSONEW("RX #")=PSOX
MANUALX IF $GET(PSONRXN("ERR FLG"))=1
SET (PSONEW("DFLG"),PSONEW("QFLG"))=1
+1 KILL PSONRXN,X,Y,DIRUT,DTOUT,DUOUT,DIC,DIE,DR,PSOX,PSODIR,PSOX1
+2 QUIT
+3 ;
AUTO ; Entry point for getting next rx # if autonumbering
+1 SET PSONEW("QFLG")=0
+2 SET PSONRXN("TYPE")=$SELECT('+$GET(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")[2&(+$GET(^PS(59,+PSOSITE,2))):3,1:8)
+3 LOCK +^PS(59,+PSOSITE,PSONRXN("TYPE")):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
+4 SET PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE"))
SET PSONRXN("LO")=$PIECE(PSOX1,"^")
+5 SET PSONRXN("HI")=$PIECE(PSOX1,"^",2)
SET PSOI=$PIECE(PSOX1,"^",3)
SET PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI
+6 if PSOI<PSONRXN("LO")
SET PSOI=PSONRXN("LO")
LOOP2 FOR
SET PSOI=PSOI+1
if PSOI>PSONRXN("HI")
DO FATAL
if '$DATA(^PSRX("B",PSOI))!PSONEW("QFLG")
QUIT
+1 if PSONEW("QFLG")
GOTO AUTOX
+2 KILL DUP
LOCK +^PSRX("B",PSOI):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
Begin DoDot:1
+3 IF $DATA(^PSRX("B",PSOI))!'$TEST
LOCK -^PSRX("B",PSOI)
SET DUP=1
QUIT
+4 FOR I=65:1:90
IF $DATA(^PSRX("B",PSOI_$CHAR(I)))
LOCK -^PSRX("B",PSOI)
SET DUP=1
QUIT
End DoDot:1
IF $GET(DUP)
KILL DUP,I
GOTO LOOP2
+5 KILL DIC,DIE,DA,DUP,I
+6 SET DIE=59
SET DA=PSOSITE
+7 SET DR=$SELECT(PSONRXN("TYPE")=8:"2003////"_PSOI,PSONRXN("TYPE")=3:"1002.1////"_PSOI,1:"2003////"_PSOI)
+8 SET PSONEW("RX #")=PSOI
+9 DO ^DIE
KILL DIE,DIC,DR,DA
+10 LOCK -^PS(59,+PSOSITE,PSONRXN("TYPE"))
AUTOX KILL PSOX1,PSONRXN,PSOI,X,Y
+1 QUIT
+2 ;
FATAL ;error in autonum queue if necessary and quit
+1 WRITE !!,$CHAR(7),"Fatal error in Autonumbering - No Numbers Left!",!,"See Application Package Coordinator!",!,$CHAR(7)
+2 SET PSONEW("QFLG")=1
SET DIR("A")="Enter RETURN to continue"
DO PAUSE^VALM1
+3 QUIT
