source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUCHG.m@ 1042

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

initial load of WorldVistAEHR

File size: 9.2 KB
Line 
1PSOSUCHG ;BIR/RTR-CHANGE SUSPENSE AND FILL AND REFILL DATES ;4/29/93
2 ;;7.0;OUTPATIENT PHARMACY;**20,26,130,235,148**;DEC 1997
3 ;External reference A^PSXCH is supported by DBIA 2205
4 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
5 ;External reference P^PSXCH is supported by DBIA 2205
6 ;External reference to ^PS(55 supported by DBIA 2228
7 ;External reference to ^DPT supported by DBIA 10035
8 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) D WARN^PSOSUDCN Q
9LU N PSOSDLK,PSOLKQT,PSODELLK,PSOSSTP W !! S DIR("A")="Change a specific Rx# or all Rx's for one patient",DIR(0)="SBO^S:SPECIFIC RX;A:ALL RXs FOR ONE PATIENT"
10 S DIR("?",1)="Enter 'S' to change a single prescription suspense date.",DIR("?")="Enter 'A' to change all of the prescription suspense dates for one patient."
11 D ^DIR K DIR G:$G(DIRUT)!(Y="") EXIT S ACT=Y D:ACT="A" ALL D:ACT="S" SPEC D ULK G LU
12EXIT D ULK K ISFLAG,ACT,BC,BCNUM,CBD,CNT,COM,D1,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,HDSFN,I,II,INDT,OLD,OUT,PSPOP,RF,RFCNT,RX,RXDATE,RXREC,SFN,STOP,SUB,SUSCNT,VADM,WARN,X,Y,XOK,SRXPAR,SRXREC,SUSDOD,RECORD,PSOPOPUP,PSOSDLK,DELFLAG
13 K VADM,VA("PID"),VA("BID"),PSDIVCHK,PSOMSG,PSOLKQT,PSODELLK,PSOSSTP Q
14SPEC D ULK K INDT S (DELCNT,WARN,PSPOP,OUT)=0 W ! S DIR("A")="Select SUSPENDED Rx #: ",DIR(0)="FOA",DIR("?")="Enter the prescription# or wand the barcode. To obtain a list of suspense prescriptions, type '??'",DIR("??")="^D LISTSUS^PSOSUCH1"
15 D ^DIR K DIR Q:$D(DIRUT) D:Y["-" PSOINST^PSOSUPAT G:$G(OUT) SPEC D W ! S DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0))",DIC="^PS(52.5,",DIC(0)="ZQE" D ^DIC K DIC W ! Q:$D(DTOUT)!($D(DUOUT))
16 .I Y["-" S Y=$P(Y,"-",2),X=+$P($G(^PSRX(Y,0)),"^") Q
17 .S X=Y
18 G:Y<0 SPEC S DEAD=0,(SFN,DA)=+Y,RXREC=+Y(0),DFN=$P(^PS(52.5,SFN,0),"^",3),RXDATE=$P(Y(0),"^",2),STOP=$P(^PSRX(RXREC,2),"^",6),STAT=$P($G(^("STA")),"^") D Q:$G(PSOLKQT) D TST G:$T P^PSXCH
19 .K PSOMSG,PSOLKQT D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !,"Rx number: "_$P($G(^PSRX(RXREC,0)),"^")_" cannot be changed because" D LMES,PAUSE S PSOLKQT=1 K PSOMSG Q
20 .K PSOMSG S PSOSDLK(RXREC)=""
21RTN I STAT=11!(STOP<DT)!(STAT=12) D EXPCAN Q
22 D:$P($G(^PSRX(RXREC,"STA")),"^")<9 CHKDEAD^PSOSUCH1 Q:DEAD I $G(PSODIV),+$P($G(^PS(52.5,SFN,0)),"^",6)'=PSOSITE S PSPOP=0 D CKDIV^PSOSUPAT Q:PSPOP
23 S DA=SFN,DIE=52.5,DR=".02;S INDT=X" D ^DIE K DIE D Q:$D(Y) W !
24 .I $D(INDT),INDT'=RXDATE,INDT<+$P($G(^PSRX(RXREC,0)),"^",13) S DA=SFN,DIE=52.5,DR=".02///"_RXDATE D ^DIE K DIE S Y="" W !!,"Suspense date cannot be before Issue Date of Rx!",!
25 I $D(X),X'=RXDATE S DA=RXREC D CHANGE^PSOSUCH1(RXREC)
26 D DEL G:ACT="A" ALL G:ACT="S" SPEC
27ALL D ULK K INDT S (DELCNT,PSDIVCHK,DELFLAG,PSPOP,PSOPOPUP,WARN,SUSCNT)=0 W ! S DIR("A")="Are you entering the patient name or barcode?",DIR(0)="SBO^P:Patient Name;B:Barcode"
28 S DIR("?")="Enter 'P' if you are going to enter the patient name. Enter 'B' to enter or wand the barcode." D ^DIR K DIR Q:$D(DIRUT) S BC=Y
29BC S OUT=0 I BC="B" W ! S DIR("A")="Enter/wand barcode",DIR(0)="FO^5:20",DIR("?")="Enter the barcode number or wand the barcode to change all of the prescription suspense dates for one patient" D ^DIR K DIR G:$G(DIRUT) ALL S BCNUM=Y D
30 .S RX=$P(BCNUM,"-",2) I '$G(RX) S OUT=1 W $C(7),!!?5,"Invalid Barcode!" Q
31 .I $D(^PSRX(RX,0)) D PSOINST^PSOSUPAT Q:OUT S DFN=$P(^PSRX(RX,0),"^",2) W " ",$P($G(^DPT(DFN,0)),"^")
32 G:OUT BC
33 I BC="B",'$D(^PSRX(RX,0)) W $C(7),!!?5,"Invalid Barcode!",! G BC
34 I BC="B",'$D(^PS(52.5,"AC",DFN)) W !!?3,"This patient has no Rx's in suspense that have not already been printed!",! G BC
35NAM I BC="P" W ! S DIC(0)="AEMZQ",DIC="^DPT(",DIC("S")="I $D(^PS(52.5,""AC"",+Y))!($D(^PS(52.5,""AG"",+Y)))" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) ALL S DFN=+Y
36 F CBD=0:0 S CBD=$O(^PS(55,DFN,"P",CBD)) Q:CBD'>0!($G(PSOPOPUP)) S:$D(^PS(55,DFN,"P",CBD,0)) RXREC=+^(0) D:$D(^PS(52.5,"B",RXREC)) TEST D ULK
37 G:ACT="A" ALL G:ACT="S" SPEC
38TEST S SFN=+$O(^PS(52.5,"B",RXREC,0)) Q:'SFN Q:$P($G(^PS(52.5,SFN,"P")),"^")'=0 S STOP=$P(^PSRX(RXREC,2),"^",6),STAT=$P($G(^("STA")),"^") D Q:$G(PSOLKQT) D TST D:$T A^PSXCH Q:$G(XOK)=0 I STAT=11!(STOP<DT)!(STAT=12) D EXPCAN Q
39 .K PSOMSG,PSOLKQT D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !!,"Rx number: "_$P($G(^PSRX(RXREC,0)),"^")_" cannot be changed because" D LMES,PAUSE S PSOLKQT=1 K PSOMSG Q
40 .K PSOMSG S PSOSDLK(RXREC)=""
41 S PSPOP=0 D:PSODIV&('$G(PSDIVCHK)) DIV^PSOSUPAT S PSDIVCHK=1 S:PSPOP PSOPOPUP=1 I 'PSPOP D:$P($G(^PSRX(RXREC,"STA")),"^")<9 CHKDEAD^PSOSUCH1 Q:DEAD D BEG
42 Q
43BEG S RXDATE=$P(^PS(52.5,SFN,0),"^",2),ISFLAG=0
44 I 'SUSCNT S DA=SFN,DIE=52.5,DR=".02;S INDT=X" D ^DIE D SI Q:ISFLAG K:$G(^PS(52.5,SFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P(^PS(52.5,SFN,0),"^",2),SFN) S:$D(Y) PSOPOPUP=1 Q:X=""!($D(DTOUT))!($G(PSOPOPUP)) S SUSCNT=1
45 I SUSCNT D IS Q:$G(ISFLAG) S DA=SFN,DIE=52.5,DR=".02///"_INDT D ^DIE K DIE K:$G(^PS(52.5,SFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P($G(^PS(52.5,SFN,0)),"^",2),SFN) I $D(DTOUT)!($D(DUOUT))!($D(Y)) S PSOPOPUP=1 Q
46 D CHANGE^PSOSUCH1(RXREC)
47DEL I 'DELCNT W !! S DIR("A")="Do you want to delete"_$S($G(ACT)="S":" this Rx ",1:" Rx's ")_"from suspense"_$S($G(ACT)="A":" for this patient",1:""),DIR("B")="N",DIR(0)="Y" D ^DIR K DIR S DELCNT=1 S DEL=Y Q:'Y I $D(DIRUT) S PSOPOPUP=1 Q
48 I $G(ACT)="A",DELCNT,$G(DEL),'$G(DELFLAG) W !!,"Deleting Rx's from suspense..",! S DELFLAG=1 D DEL1 Q
49 Q:'DEL
50 I '$D(PSOSDLK(RXREC)) D Q:$G(PSODELLK)
51 .K PSOMSG,PSODELLK D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !,"Rx number: "_$P($G(^PSRX(RXREC,0)),"^")_" cannot be deleted from suspense because" D LMES,PAUSE S PSODELLK=1 K PSOMSG Q
52 .K PSOMSG S PSOSDLK(RXREC)=""
53 I DEL S DA=$O(^PS(52.5,"B",RXREC,0)) D RF S DIK="^PS(52.5," D ^DIK K DIK D:$P(^PSRX(RXREC,"STA"),"^")=5 W:$G(ACT)="S" !!,"Rx# ",$P($G(^PSRX(RXREC,0)),"^")," has been deleted from suspense!",!
54 .S $P(^PSRX(RXREC,"STA"),"^")=0
55 .N PSOZZD S PSOZZD="Removed from suspense" D EN^PSOHLSN1(RXREC,"SC","ZU",PSOZZD) K PSOZZD Q
56 Q
57EXPCAN S DIK="^PS(52.5,",DA=SFN D ^DIK K DIK S Y=STOP D DD^%DT S PSOSSTP=Y I STOP<DT!(STAT=11) D:STAT'=11 W $C(7),!,"Rx# "_$P($G(^PSRX(RXREC,0)),"^")_" expired "_$G(PSOSSTP)_"."
58 .S $P(^PSRX(RXREC,"STA"),"^")=11
59 .N PSOZZD S PSOZZD="Expired while suspended" D EN^PSOHLSN1(RXREC,"SC","ZE",PSOZZD) K PSOZZD
60 W:STAT=12 $C(7),!,"Rx# "_$P(^PSRX(RXREC,0),"^")_" was discontinued "_Y_"." K STAT,STOP Q
61TST N X S X="PSXCH" X ^%ZOSF("TEST") K X Q
62 ;
63RF ;
64 S PSSHLDDA=DA,PSODFS=0
65 S SNODE=$G(^PS(52.5,DA,0)),PSINN=+SNODE D DAREC^PSOSUCH1 I '$G(PSINN)!($P(SNODE,"^",5)) K PSINN,SNODE,PSODFS S DA=PSSHLDDA Q
66 S PSIFN=0 F S PSIFN=$O(^PSRX(PSINN,1,PSIFN)) Q:'PSIFN D
67 .I $P($G(^PSRX(PSINN,1,PSIFN,0)),"^")=$P(SNODE,"^",2),'$P($G(^PSRX(PSINN,1,PSIFN,0)),"^",18),$P($G(^PS(52.5,+$G(PSSHLDDA),"P")),"^")=0 D
68 ..N DIK,DA S DIK="^PSRX("_PSINN_",1,",DA(1)=PSINN,DA=PSIFN D ^DIK
69 ..S PSODFS=1,PSUSD=$P(SNODE,"^",2) D DATE
70 I '$G(PSODFS) G RFPS
71 S PSIFN=0 F S PSIFN=$O(^PSRX(PSINN,1,PSIFN)) Q:'PSIFN I '$O(^PSRX(PSINN,1,PSIFN)) S $P(^PSRX(PSINN,3),"^")=+$P(^PSRX(PSINN,1,PSIFN,0),"^")
72 I '$O(^PSRX(PSINN,1,0)) S $P(^PSRX(PSINN,3),"^")=$P(^PSRX(PSINN,2),"^",2)
73 S PSOX("IRXN")=PSINN D NEXT^PSOUTIL(.PSOX) S PSONEXT=$P(PSOX("RX3"),"^",2),DA=PSINN,DIE=52,DR="102///"_PSONEXT D ^DIE K DIE K PSONEXT,PSOX
74RFPS K PSODFS,ZZZ,PSINN,PSIFN,PSUSD,PNOD,SNODE S DA=PSSHLDDA K PSSHLDDA Q
75DATE S PNOD=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(PSINN,1,ZZZ)) Q:'ZZZ S PNOD=ZZZ
76 I PNOD=1 S $P(^PSRX(PSINN,3),"^",4)=$P(^PSRX(PSINN,2),"^",2) Q
77DATEX I $G(PNOD) S PNOD=PNOD-1 G:'$D(^PSRX(PSINN,1,PNOD,0)) DATEX
78 I PNOD=0 S $P(^PSRX(PSINN,3),"^",4)=$P(^PSRX(PSINN,2),"^",2) Q
79 S $P(^PSRX(PSINN,3),"^",4)=$P(^PSRX(PSINN,1,PNOD,0),"^") Q
80 Q
81IS K DIE I $G(INDT),$G(INDT)<+$P($G(^PSRX(RXREC,0)),"^",13) S DIE=52.5,DA=SFN,DR=".02///"_RXDATE D ^DIE K DIE W !!,"Suspense date cannot be before Issue Date for Rx# ",$P($G(^PSRX(RXREC,0)),"^") S ISFLAG=1
82 Q
83SI ;
84 S SUSCNT=1
85 I $D(Y) S (ISFLAG,PSOPOPUP)=1
86 G IS
87DEL1 ;
88 S PSOSUPOP=1
89 F WW=0:0 S WW=$O(^PS(55,DFN,"P",WW)) Q:WW'>0 S:$D(^PS(55,DFN,"P",WW,0)) RXREC=+^(0) D:$D(^PS(52.5,"B",+$G(RXREC)))
90 .I '$D(PSOSDLK(RXREC)) K PSODELLK D DELONE Q:$G(PSODELLK)
91 .I $P($G(^PSRX(RXREC,"STA")),"^")=11!($P($G(^PSRX(RXREC,2)),"^",6)<DT) D EXPCAN1 Q
92 .S DA=$O(^PS(52.5,"B",RXREC,0)) D RF S DIK="^PS(52.5," D ^DIK K DIK D:$P(^PSRX(RXREC,"STA"),"^")=5 W:$G(ACT)="S" !!,"Rx# ",$P($G(^PSRX(RXREC,0)),"^")," has been deleted from suspense!",!
93 ..S $P(^PSRX(RXREC,"STA"),"^")=0
94 ..N PSOZZD S PSOZZD="Removed from suspense" D EN^PSOHLSN1(RXREC,"SC","ZU",PSOZZD) K PSOZZD Q
95 Q
96ULK ;Unlock prescriptions
97 I '$O(PSOSDLK("")) Q
98 N PSOSDLKR S PSOSDLKR="" F S PSOSDLKR=$O(PSOSDLK(PSOSDLKR)) Q:PSOSDLKR="" D PSOUL^PSSLOCK(PSOSDLKR)
99 K PSOSDLK
100 Q
101PAUSE ;
102 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR W !
103 Q
104LMES ;
105 W !,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order.")
106 Q
107DELONE ;
108 K PSOMSG,PSODELLK D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !,"Rx number: "_$P($G(^PSRX(RXREC,0)),"^")_" cannot be deleted from suspense because" D LMES,PAUSE S PSODELLK=1 K PSOMSG Q
109 K PSOMSG S PSOSDLK(RXREC)=""
110 Q
111EXPCAN1 ;
112 N SFN,Y,PSOSSTP,STAT,STOP
113 S STAT=$P($G(^PSRX(RXREC,"STA")),"^"),STOP=$P($G(^PSRX(RXREC,2)),"^",6)
114 S SFN=+$O(^PS(52.5,"B",RXREC,0)) Q:'SFN
115 S DIK="^PS(52.5,",DA=SFN D ^DIK K DIK S Y=STOP D DD^%DT S PSOSSTP=Y I STOP<DT!(STAT=11) D:STAT'=11 W $C(7),!,"Rx# "_$P($G(^PSRX(RXREC,0)),"^")_" expired "_$G(PSOSSTP)_"."
116 .S $P(^PSRX(RXREC,"STA"),"^")=11
117 .N PSOZZD S PSOZZD="Expired while suspended" D EN^PSOHLSN1(RXREC,"SC","ZE",PSOZZD) K PSOZZD
118 Q
Note: See TracBrowser for help on using the repository browser.