- 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 Feb 18, 2025@23:57:57 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