Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSONRXN

PSONRXN.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;External reference to ^PSDRUG supported by DBIA 221
  1. ;External reference to ^DIC supported by DBIA 10006
  1. ;External reference to ^DIE supported by DBIA 10018
  1. ;External reference to ^DIR supported by DBIA 10026
  1. ;External reference to ^VALM1 supported by DBIA 10016
  1. ;External reference to ^DPT( supported by DBIA 10035
  1. ;
  1. ; This routine asks for the next rx # if manually assigning rx#
  1. ; and gets next rx# if auto numbering.
  1. ;
  1. ;-------------------------------------------------------------------
  1. ;
  1. MANUAL ; Entry Point to ask user for new rx #
  1. ;
  1. S PSONEW("DFLG")=0
  1. K DIR S DIR(0)="52,.01O"
  1. S DIR("A")="Select New Rx # for "_$S($G(PSORX("NAME"))]"":PSORX("NAME"),1:"")
  1. I $G(PSONEW("RX #"))]"",'$G(COPY) S DIR("B")=PSONEW("RX #")
  1. D DIR^PSODIR2 K DIR,DIC,DIE,DA
  1. I X="" S PSONEW("QFLG")=1 G MANUALX
  1. I "Pp"[Y K Y D ^PSODSPL G MANUAL
  1. I "Rr"[Y K Y S (PSONEW("QFLG"),PSORX("DO REFILL"))=1 G MANUALX
  1. I $G(PSODIR("DFLG"))=1 S (PSONEW("QFLG"),PSORX("QFLG"))=1 G MANUALX
  1. G:$G(PSONEW("FIELD")) MANUALX
  1. S PSOX=Y
  1. ;
  1. CHECK ; Entry Point to check if valid new rx number
  1. S:'$D(PSOX) PSOX=$G(PSONEW("RX #"))
  1. S PSONRXN("ERR FLG")=0
  1. S DIC="^PSRX(",DIC(0)="XZ",X=PSOX D ^DIC K DIC
  1. I Y'<0 D G MANUALX
  1. . 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")
  1. . S PSONRXN("ID")=$P(Y(0),"^",13)
  1. . I PSONRXN("ID") W !,"Issued: ",$E(PSONRXN("ID"),4,5),"-",$E(PSONRXN("ID"),6,7),"-",$E(PSONRXN("ID"),2,3)
  1. . K PSONRXN("ID"),Y
  1. . W:$G(PSODRUG("NAME")) !,"RX DELETED",!
  1. . S PSONRXN("ERR FLG")=1
  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
  1. . Q
  1. L +^PSRX("B",PSOX):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T L -^PSRX("B",PSOX) D G MANUALX
  1. . W $C(7),?10,"Prescription Rx# "_PSOX_" already being processed."
  1. . W:$G(PSODRUG("NAME")) !,"Rx Deleted",!
  1. . S PSONRXN("ERR FLG")=1
  1. . Q
  1. S PSONEW("RX #")=PSOX
  1. MANUALX I $G(PSONRXN("ERR FLG"))=1 S (PSONEW("DFLG"),PSONEW("QFLG"))=1
  1. K PSONRXN,X,Y,DIRUT,DTOUT,DUOUT,DIC,DIE,DR,PSOX,PSODIR,PSOX1
  1. Q
  1. ;
  1. AUTO ; Entry point for getting next rx # if autonumbering
  1. S PSONEW("QFLG")=0
  1. S PSONRXN("TYPE")=$S('+$G(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")[2&(+$G(^PS(59,+PSOSITE,2))):3,1:8)
  1. L +^PS(59,+PSOSITE,PSONRXN("TYPE")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
  1. S PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE")),PSONRXN("LO")=$P(PSOX1,"^")
  1. S PSONRXN("HI")=$P(PSOX1,"^",2),PSOI=$P(PSOX1,"^",3),PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI
  1. S:PSOI<PSONRXN("LO") PSOI=PSONRXN("LO")
  1. LOOP2 F S PSOI=PSOI+1 D:PSOI>PSONRXN("HI") FATAL Q:'$D(^PSRX("B",PSOI))!PSONEW("QFLG")
  1. G:PSONEW("QFLG") AUTOX
  1. K DUP L +^PSRX("B",PSOI):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) D I $G(DUP) K DUP,I G LOOP2
  1. .I $D(^PSRX("B",PSOI))!'$T L -^PSRX("B",PSOI) S DUP=1 Q
  1. .F I=65:1:90 I $D(^PSRX("B",PSOI_$C(I))) L -^PSRX("B",PSOI) S DUP=1 Q
  1. K DIC,DIE,DA,DUP,I
  1. S DIE=59,DA=PSOSITE
  1. S DR=$S(PSONRXN("TYPE")=8:"2003////"_PSOI,PSONRXN("TYPE")=3:"1002.1////"_PSOI,1:"2003////"_PSOI)
  1. S PSONEW("RX #")=PSOI
  1. D ^DIE K DIE,DIC,DR,DA
  1. L -^PS(59,+PSOSITE,PSONRXN("TYPE"))
  1. AUTOX K PSOX1,PSONRXN,PSOI,X,Y
  1. Q
  1. ;
  1. FATAL ;error in autonum queue if necessary and quit
  1. W !!,$C(7),"Fatal error in Autonumbering - No Numbers Left!",!,"See Application Package Coordinator!",!,$C(7)
  1. S PSONEW("QFLG")=1 S DIR("A")="Enter RETURN to continue" D PAUSE^VALM1
  1. Q