| 1 | PSOSUCH1 ;BHAM ISC/JMB-Change suspense and fill/refill dates ; 4/49/93
|
|---|
| 2 | ;;7.0;OUTPATIENT PHARMACY;**148**;DEC 1997
|
|---|
| 3 | LISTSUS S X="?",DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")<11,$P($G(^PS(52.5,+Y,""P"")),""^"")=0",DIC="^PS(52.5,",DIC(0)="ZQ" D ^DIC K DIC W ! Q:Y<0!($D(DTOUT)) Q
|
|---|
| 4 | LISTPAT S X="?",DIC(0)="EMQ",DIC="^DPT(",DIC("S")="I $D(^PS(52.5,""AC"",+Y))" D ^DIC K DIC Q
|
|---|
| 5 | PSOINST S PSOINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^") I Y["-",'$D(^PSRX($P(Y,"-",2),0)) W !,?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G SPEC^PSOSUCHG:ACT="S" G ALL^PSOSUCHG:ACT="A"
|
|---|
| 6 | I Y["-",$P(Y,"-")'=PSOINST W !,?7,$C(7),$C(7),$C(7)," NOT FROM THIS INSTITUTION" G SPEC^PSOSUCHG:ACT="S" G ALL^PSOSUCHG:ACT="A"
|
|---|
| 7 | Q
|
|---|
| 8 | AREC S:'DEAD COM="Change "_$S($G(PSOSUSPA):"Partial",'$G(SUB):"Fill",1:"Refill")_" Date "_$E(OLD,4,5)_"/"_$E(OLD,6,7)_"/"_$E(OLD,2,3)_" to "_$E(INDT,4,5)_"/"_$E(INDT,6,7)_"/"_$E(INDT,2,3)
|
|---|
| 9 | S CNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXREC,"A",SUB)) Q:'SUB S CNT=SUB
|
|---|
| 10 | S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXREC,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
|
|---|
| 11 | D NOW^%DTC S CNT=CNT+1 S ^PSRX(RXREC,"A",0)="^52.3DA^"_CNT_"^"_CNT,^PSRX(RXREC,"A",CNT,0)=%_"^"_$S(DEAD:"C",1:"S")_"^"_DUZ_"^"_$S($G(PSOSUSPA):6,1:RFCNT)_"^"_COM K PSOSUSPA Q
|
|---|
| 12 | CHKDEAD D DEM^VADPT I VADM(1)="" W !?10,"PATIENT NAME UNKNOWN" S DEAD=0 Q
|
|---|
| 13 | I VADM(6)="" S DEAD=0 Q
|
|---|
| 14 | S SUSDOD=$P(VADM(6),"^",2)
|
|---|
| 15 | F RXREC=0:0 S RXREC=$O(^PS(52.5,"AC",DFN,RXREC)) Q:'RXREC F SRXREC=0:0 S SRXREC=$O(^PS(52.5,"AC",DFN,RXREC,SRXREC)) Q:'SRXREC S RECORD=$P($G(^PS(52.5,SRXREC,0)),"^") D:RECORD DEAD
|
|---|
| 16 | Q
|
|---|
| 17 | DEAD S HOLD=$G(DA),REA="C",COM="Died ("_$G(SUSDOD)_")",DA=RECORD,DEAD=1 D CAN^PSOCAN
|
|---|
| 18 | W:'WARN !!,?10,$P($G(^DPT(DFN,0)),"^")_" DIED "_SUSDOD_" all prescriptions were discontinued" W:'WARN !,?15," and deleted from the suspense file." S WARN=1,DA=HOLD K HOLD,REA
|
|---|
| 19 | Q
|
|---|
| 20 | NEXT S PSOX("IRXN")=RXREC D NEXT^PSOUTIL(.PSOX) S NEXT=$P(PSOX("RX3"),"^",2),DA=RXREC,DIE=52,DR="102///"_NEXT D ^DIE K DIE Q:$D(DTOUT)!($D(DUOUT))
|
|---|
| 21 | K NEXT,PSOX Q
|
|---|
| 22 | ;
|
|---|
| 23 | CHANGE(RXREC,SUB) ; File update for Suspense Date change
|
|---|
| 24 | I $P($G(^PS(52.5,SFN,0)),"^",5) S PSOSUSPA=1,HDSFN=SFN S SRXPAR=+$P(^(0),"^",5),OLD=+$P($G(^PSRX(RXREC,"P",SRXPAR,0)),"^"),DA(1)=RXREC,DA=SRXPAR,DIE="^PSRX("_DA(1)_",""P"",",DR=".01////"_INDT D ^DIE G FIN
|
|---|
| 25 | I '$D(SUB) S SUB=0 F II=0:0 S II=$O(^PSRX(RXREC,1,II)) Q:'II S SUB=+II
|
|---|
| 26 | S HDSFN=SFN I 'SUB S (X,OLD)=$P(^PSRX(RXREC,2),"^",2),DA=RXREC,DR="22///"_INDT_";101///"_INDT,DIE=52 D
|
|---|
| 27 | .D ^DIE K DIE K:$G(^PS(52.5,HDSFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P($G(^PS(52.5,HDSFN,0)),"^",2),HDSFN) Q:$D(DTOUT)!($D(DUOUT)) D NEXT K DA Q
|
|---|
| 28 | I SUB S (OLD,X)=+$P($G(^PSRX(RXREC,1,SUB,0)),"^"),DA(1)=RXREC,DA=SUB,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_INDT D ^DIE K DIE S $P(^PSRX(RXREC,3),"^")=INDT D
|
|---|
| 29 | .K:$G(^PS(52.5,HDSFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P($G(^PS(52.5,HDSFN,0)),"^",2),HDSFN) D NEXT S DA=RXREC K DA Q
|
|---|
| 30 | FIN S DA=HDSFN,DIK="^PS(52.5," D IX1^DIK
|
|---|
| 31 | S SFN=HDSFN D AREC N X S X="PSXCH" X ^%ZOSF("TEST") K X Q:'$T D:$G(XOK)=1 X^PSXCH Q
|
|---|
| 32 | Q
|
|---|
| 33 | ;
|
|---|
| 34 | DAREC ;
|
|---|
| 35 | S SCOM="Rx "_$S($P(SNODE,"^",5):"(Partial) ",1:"")_"deleted from suspense"
|
|---|
| 36 | S SSX=0 F SSXX=0:0 S SSXX=$O(^PSRX(RXREC,"A",SSXX)) Q:'SSXX S SSX=SSXX
|
|---|
| 37 | S SXCNT=0 F SCXX=0:0 S SCXX=$O(^PSRX(RXREC,1,SCXX)) Q:'SCXX S SXCNT=SCXX S:SCXX>5 SXCNT=SCXX+1
|
|---|
| 38 | D NOW^%DTC S SSX=SSX+1 S ^PSRX(RXREC,"A",0)="^52.3DA^"_SSX_"^"_SSX,^PSRX(RXREC,"A",SSX,0)=%_"^"_"S"_"^"_DUZ_"^"_$S($P(SNODE,"^",5):6,1:SXCNT)_"^"_SCOM
|
|---|
| 39 | K SCOM,SSX,SSXX,SXCNT,SCXX Q
|
|---|
