source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONRXN.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.5 KB
RevLine 
[613]1PSONRXN ;IHS/DSD/JCM - GETS NEXT VALID RX NUMBER ;08/09/93 9:17
2 ;;7.0;OUTPATIENT PHARMACY;**5,25,166,268**;DEC 1997;Build 9
3 ;
4 ;External reference to ^PSDRUG supported by DBIA 221
5 ;External reference to ^DIC supported by DBIA 10006
6 ;External reference to ^DIE supported by DBIA 10018
7 ;External reference to ^DIR supported by DBIA 10026
8 ;External reference to ^VALM1 supported by DBIA 10016
9 ;External reference to ^DPT( supported by DBIA 10035
10 ;
11 ; This routine asks for the next rx # if manually assigning rx#
12 ; and gets next rx# if auto numbering.
13 ;
14 ;-------------------------------------------------------------------
15 ;
16MANUAL ; Entry Point to ask user for new rx #
17 ;
18 S PSONEW("DFLG")=0
19 K DIR S DIR(0)="52,.01O"
20 S DIR("A")="Select New Rx # for "_$S($G(PSORX("NAME"))]"":PSORX("NAME"),1:"")
21 I $G(PSONEW("RX #"))]"",'$G(COPY) S DIR("B")=PSONEW("RX #")
22 D DIR^PSODIR2 K DIR,DIC,DIE,DA
23 I X="" S PSONEW("QFLG")=1 G MANUALX
24 I "Pp"[Y K Y D ^PSODSPL G MANUAL
25 I "Rr"[Y K Y S (PSONEW("QFLG"),PSORX("DO REFILL"))=1 G MANUALX
26 I $G(PSODIR("DFLG"))=1 S (PSONEW("QFLG"),PSORX("QFLG"))=1 G MANUALX
27 G:$G(PSONEW("FIELD")) MANUALX
28 S PSOX=Y
29 ;
30CHECK ; Entry Point to check if valid new rx number
31 S:'$D(PSOX) PSOX=$G(PSONEW("RX #"))
32 S PSONRXN("ERR FLG")=0
33 S DIC="^PSRX(",DIC(0)="XZ",X=PSOX D ^DIC K DIC
34 I Y'<0 D G MANUALX
35 . 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")
36 . S PSONRXN("ID")=$P(Y(0),"^",13)
37 . I PSONRXN("ID") W !,"Issued: ",$E(PSONRXN("ID"),4,5),"-",$E(PSONRXN("ID"),6,7),"-",$E(PSONRXN("ID"),2,3)
38 . K PSONRXN("ID"),Y
39 . W:$G(PSODRUG("NAME")) !,"RX DELETED",!
40 . S PSONRXN("ERR FLG")=1
41 . I $G(PSOFIN)!($G(PSOFINFL)),'$G(PSOAC) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
42 . Q
43 L +^PSRX("B",PSOX):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T L -^PSRX("B",PSOX) D G MANUALX
44 . W $C(7),?10,"Prescription Rx# "_PSOX_" already being processed."
45 . W:$G(PSODRUG("NAME")) !,"Rx Deleted",!
46 . S PSONRXN("ERR FLG")=1
47 . Q
48 S PSONEW("RX #")=PSOX
49MANUALX I $G(PSONRXN("ERR FLG"))=1 S (PSONEW("DFLG"),PSONEW("QFLG"))=1
50 K PSONRXN,X,Y,DIRUT,DTOUT,DUOUT,DIC,DIE,DR,PSOX,PSODIR,PSOX1
51 Q
52 ;
53AUTO ; Entry point for getting next rx # if autonumbering
54 S PSONEW("QFLG")=0
55 S PSONRXN("TYPE")=$S('+$G(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")[2&(+$G(^PS(59,+PSOSITE,2))):3,1:8)
56 L +^PS(59,+PSOSITE,PSONRXN("TYPE")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
57 S PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE")),PSONRXN("LO")=$P(PSOX1,"^")
58 S PSONRXN("HI")=$P(PSOX1,"^",2),PSOI=$P(PSOX1,"^",3),PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI
59 S:PSOI<PSONRXN("LO") PSOI=PSONRXN("LO")
60LOOP2 F S PSOI=PSOI+1 D:PSOI>PSONRXN("HI") FATAL Q:'$D(^PSRX("B",PSOI))!PSONEW("QFLG")
61 G:PSONEW("QFLG") AUTOX
62 K DUP L +^PSRX("B",PSOI):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) D I $G(DUP) K DUP,I G LOOP2
63 .I $D(^PSRX("B",PSOI))!'$T L -^PSRX("B",PSOI) S DUP=1 Q
64 .F I=65:1:90 I $D(^PSRX("B",PSOI_$C(I))) L -^PSRX("B",PSOI) S DUP=1 Q
65 K DIC,DIE,DA,DUP,I
66 S DIE=59,DA=PSOSITE
67 S DR=$S(PSONRXN("TYPE")=8:"2003////"_PSOI,PSONRXN("TYPE")=3:"1002.1////"_PSOI,1:"2003////"_PSOI)
68 S PSONEW("RX #")=PSOI
69 D ^DIE K DIE,DIC,DR,DA
70 L -^PS(59,+PSOSITE,PSONRXN("TYPE"))
71AUTOX K PSOX1,PSONRXN,PSOI,X,Y
72 Q
73 ;
74FATAL ;error in autonum queue if necessary and quit
75 W !!,$C(7),"Fatal error in Autonumbering - No Numbers Left!",!,"See Application Package Coordinator!",!,$C(7)
76 S PSONEW("QFLG")=1 S DIR("A")="Enter RETURN to continue" D PAUSE^VALM1
77 Q
Note: See TracBrowser for help on using the repository browser.