- PSOSUPAT ;BIR/RTR-Pull all Rx's from suspense for a patient ;03/01/96
- ;;7.0;OUTPATIENT PHARMACY;**8,130,185**;DEC 1997
- ;External reference to ^PS(55 supported by DBIA 2228
- ;External reference to ^PSSLOCK supported by DBIA 2789
- PAT N PSOALRX,PSOALRXS S POP=0 K RXP,RXRR,RXFL,RXRP,RXPR,ASKED,BC,DELCNT,WARN,PSOAL,PSOPROFL,PSOQFLAG,PSOPULL,PSOWIN,PSOWINEN,PPLHOLD,PPLHOLDX W ! S DIR("A")="Are you entering the patient name or barcode",DIR(0)="SBO^P:Patient Name;B:Barcode"
- S DIR("?")="Enter P if you are going to enter the patient name. Enter B if you are going to enter or wand the barcode."
- D ^DIR K DIR G:$D(DIRUT) ^PSOSUPRX S BC=Y D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
- BC S (OUT,POP)=0 I BC="B" W ! S DIR("A")="Enter/wand barcode",DIR(0)="FO^5:20",DIR("?")="Enter or wand a prescription barcode for the patient you wish to pull all Rx's for" D ^DIR K DIR G:$G(DIRUT) PAT S BCNUM=Y D
- .D PSOINST Q:OUT S RX=$P(BCNUM,"-",2) K RTE S MW="" D:$D(^PSRX(RX,0))
- ..S (DFN,PSODFN)=$P(^PSRX(RX,0),"^",2) W " ",$P($G(^DPT(DFN,0)),"^")
- ..D ICN^PSODPT(DFN)
- .I '$D(^PSRX(RX,0)) W !,$C(7),"NO PRESCRIPTION RECORD FOR THIS BARCODE." S OUT=1
- G:OUT BC
- NAM 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) PAT S (DFN,PSODFN)=+Y K RTE S MW=""
- S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
- S (ASKED,DELCNT,WARN)=0 F CBD=0:0 S CBD=$O(^PS(55,DFN,"P",CBD)) Q:CBD'>0 D TEST
- I $G(PSOQFLAG) D RESET G EXIT
- ;S HOLDPROF=$G(PSOPROFL) K PSOPROFL
- ;I $D(PSOPART) S (PSOPULL,PSODBQ)=1 F RR=0:0 S RR=$O(PSOPART(RR)) Q:'RR S PDUZ=DUZ,PPL=RR,RXP=PSOPART(RR) D Q^PSORXL
- ;S PSOPROFL=HOLDPROF I $D(ZTSK),'$G(PPLHOLD) W !!,"LABEL(S) ARE QUEUED TO PRINT",!
- F GGGG=0:0 S GGGG=$O(RXPR(GGGG)) Q:'GGGG K:'$G(RXPR(GGGG)) RXPR(GGGG)
- K RXP,PPL S PDUZ=DUZ,PSONOPRT=1
- I $G(PPLHOLD)'="" S PPL=PPLHOLD S:$G(SUSROUTE) BBRX(1)=PPL S HOLDPPL=PPL,PSOPULL=1,PSODBQ=1,RXLTOP=1 D WIND^PSOSUPRX D Q^PSORXL I '$G(PSOQFLAG) W !!,"LABEL(S) ARE QUEUED TO PRINT",! S PPL=$P(HOLDPPL,",") D PRF D:'$G(PSOQFLAG) S PSOQFLAG=0
- .I $P(PSOPAR,"^",8),$G(PSOPROFL) W !!,"PROFILE(S) ARE QUEUED TO PRINT"
- ;call to bingo board
- I $G(PPLHOLDX),'$G(PSOQGLAG),$G(SUSROUTE) S BBRX(2)=PPLHOLDX
- D:$G(BINGRTE)&($D(DISGROUP))&('$G(PSOQFLAG)) ^PSOBING1 K BINGRTE,BBRX
- I $G(PPLHOLDX),'$G(PSOQFLAG) D S PDUZ=DUZ,PPL=PPLHOLDX,PSNP=0,(PSODBQ,PSOPULL)=1 D Q^PSORXL
- .F XXX=0:0 S XXX=$O(RXPR1(XXX)) Q:'XXX S RXPR(XXX)=$P(RXPR1(XXX),"^",2)
- .F WWWW=0:0 S WWWW=$O(RXRP1(WWWW)) Q:'WWWW S:$D(RXRP1(WWWW)) RXRP(WWWW)=1
- I $G(PSOQFLAG) D RESET
- EXIT K ACT,BCNUM,CBD,CNT,COM,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,DTTM,GG,HOLD,HOLDPPL,HDSFN,OUT,PSOPULL,PSOWIN,PSOWINEN,PSODBQ,PPLHOLD,PPLHOLDX,HOLDPROF,RR,ZZZZ,PSDNAME,PSDDDATE,ZTSK,WWWW,RXRP,RXRP1,PSONOPRT,RXFL,RXRR
- S PSOALRX="" F S PSOALRX=$O(PSOALRXS(PSOALRX)) Q:PSOALRX="" D PSOUL^PSSLOCK(PSOALRX)
- K MW,PDUZ,PPL,PRF,PSPOP,PSOPROFL,RF,RFCNT,RX,RXPR,RXPR1,RXREC,SFN,GGGG,STOP,SUB,VADM,WARN,X,Y,Y(0),%,%W,%Y,%Y1,RXLTOP,PSOGET,PSOGETF,PSOGETFN Q
- TEST I $D(^PS(55,DFN,"P",CBD,0)) S RXREC=+^(0) I +$P($G(^PSRX(RXREC,"STA")),"^")=5,$D(^PS(52.5,"B",RXREC)) S SFN=+$O(^(RXREC,0)) Q:SFN'>0!($G(PSOQFLAG))!('$D(^PS(52.5,SFN,0))) S PSPOP=0 D:$G(PSODIV) DIV I 'PSPOP D CHKDEAD Q:DEAD D BEG
- Q
- CHKDEAD D DEM^VADPT S PSDNAME=$G(VADM(1)) I VADM(1)="" W !?10,"PATIENT NAME UNKNOWN" S DEAD=0 Q
- I VADM(6)="" S DEAD=0 Q
- S PSDDDATE=$P(VADM(6),"^",2) F ZZZZ=0:0 S ZZZZ=$O(^PS(55,DFN,"P",ZZZZ)) Q:'ZZZZ I $D(^PS(55,DFN,"P",ZZZZ,0)),$P($G(^(0)),"^") S (DA,RXREC)=$P(^(0),"^") I $O(^PS(52.5,"B",DA,0)) D DEAD
- Q
- DEAD S HOLD=DA,REA="C",COM="Died ("_$G(PSDDDATE)_")",DA=RXREC,DEAD=1 D CAN^PSOCAN W:'$G(WARN) !!,?10,$G(PSDNAME)," DIED ",$G(PSDDDATE) S WARN=1,DA=HOLD K HOLD,REA Q
- DIV I $D(^PS(52.5,SFN,0)),$D(^PSRX(+$P(^PS(52.5,SFN,0),"^"),2)),$P(^PS(52.5,SFN,0),"^",6)'=$G(PSOSITE) S RXREC=+$P(^PS(52.5,SFN,0),"^") D CKDIV
- Q
- CKDIV I '$P($G(PSOSYS),"^",2) W !!?10,$C(7),"Rx # ",$P(^PSRX(RXREC,0),"^")," is not a valid choice. (Different Division)" S PSPOP=1 Q
- I $P($G(PSOSYS),"^",3) W !!?10,$C(7) S DIR("A")="Rx # "_$P(^PSRX(RXREC,0),"^")_" is from another division. Continue",DIR(0)="Y",DIR("B")="Y" D ^DIR K DIR I $G(DIRUT)!('Y) S PSPOP=1
- Q
- BEG I $P($G(^PSRX(RXREC,2)),"^",6)<DT,$P($G(^("STA")),"^")<11 D S DIE=52,DA=RXREC,DR="100///"_11 D ^DIE S DA=SFN,DIK="^PS(52.5," D ^DIK K DIE,DA,DIK W !!,"Rx #"_$P(^PSRX(RXREC,0),"^")_" has expired!" D PAUSE Q
- .D EX^PSOSUTL
- I '$D(^PS(52.5,SFN,0)) K PSOAL Q
- I +$G(^PS(52.5,SFN,"P")) W !!,$C(7),">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")_" has already been printed from suspense.",!,?5,"Use the reprint routine under the rx option to produce a label." D PAUSE Q
- S PSOALRX=$P($G(^PS(52.5,SFN,0)),"^") I PSOALRX D PSOL^PSSLOCK(PSOALRX) I '$G(PSOMSG) D D PAUSE K PSOMSG,PSOALRX Q
- .I $P($G(PSOMSG),"^",2)'="" W !!,"Rx: "_$P($G(^PSRX(PSOALRX,0)),"^")_" cannot be pulled from suspense.",!,$P($G(PSOMSG),"^",2),! Q
- .W !!,"Another person is editing Rx "_$P($G(^PSRX(PSOALRX,0)),"^"),!,"It cannot be pulled from suspense.",!
- S PSOALRXS(+$G(PSOALRX))=""
- K PSOMSG,PSOALRX
- S DA=$P(^PS(52.5,SFN,0),"^"),RXPR(DA)=+$P(^(0),"^",5),RXFL(DA)=$P($G(^(0)),"^",13)
- I $L($G(PPLHOLD))<240 S PPLHOLD=$S($G(PPLHOLD)="":$P(^PS(52.5,SFN,0),"^"),1:$G(PPLHOLD)_","_+^PS(52.5,SFN,0)) S:$P(^PS(52.5,SFN,0),"^",12) RXRP(DA)=1 G STR
- S PPLHOLDX=$S($G(PPLHOLDX)="":$P(^PS(52.5,SFN,0),"^"),1:$G(PPLHOLDX)_","_+^PS(52.5,SFN,0)) S:$G(RXPR(DA)) RXPR1(DA)=DA_"^"_RXPR(DA) S:$P(^PS(52.5,SFN,0),"^",12) RXRP1(DA)=1 K RXPR(DA)
- STR I '$D(^PSRX(RXREC,1)),'$G(RXPR(RXREC)),'$G(RXPR1(RXREC)) S PSOPROFL=1
- QUES S HDSFN=SFN D QUES^PSOSUPRX Q
- PRF I $P(PSOPAR,"^",8),'$D(PRF(DFN)),$G(PSOPROFL) S HOLD=DFN D ^PSOPRF S DFN=HOLD,PRF(DFN)=""
- Q
- PSOINST I '$D(^PSRX(+$P(Y,"-",2),0)) W !!,$C(7),"Non-existent prescription" S OUT=1 Q
- I $P(Y,"-")'=PSOINST W !!,$C(7),"The prescription is not from this institution." S OUT=1 Q
- Q
- MAIL I $D(PSOWINEN),$G(PSOWIN) S ^PSRX(RXREC,"MP")=$S(PSOWINEN'="":PSOWINEN,1:"")
- MAILS I $G(RXPR(RXREC)) S DA(1)=RXREC,DA=RXPR(RXREC),DIE="^PSRX("_DA(1)_",""P"",",DR=".02///"_MW D ^DIE K DIE Q
- S RFCNT=0 F RR=0:0 S RR=$O(^PSRX(RXREC,1,RR)) Q:'RR S RFCNT=RR
- I 'RFCNT,'$G(RXPR(RXREC)) S DA=RXREC,DIE=52,DR="11///"_MW D ^DIE
- I RFCNT,'$G(RXPR(RXREC)) S DA(1)=RXREC,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR="2///"_MW D ^DIE
- K DIE,RFCNT,RR Q
- RESET ;
- N PRSDA,PRSP,PRMW,PRMP,PRFILL,PRFILLN,PRPSRX,DA
- F PRSDA=0:0 S PRSDA=$O(RXRR(PRSDA)) Q:'PRSDA D
- .S PRSP=$O(^PS(52.5,"B",PRSDA,0)) Q:'PRSP
- .Q:'$D(^PS(52.5,PRSP,0))
- .S PRMW=$S($P($G(RXRR(PRSDA)),"^")="":"M",1:$P($G(RXRR(PRSDA)),"^")),PRMP=$P($G(RXRR(PRSDA)),"^",2),PRFILL=$P($G(RXRR(PRSDA)),"^",3),PRFILLN=$P($G(RXRR(PRSDA)),"^",4),PRPSRX=$S($P($G(RXRR(PRSDA)),"^",5)="":"M",1:$P($G(RXRR(PRSDA)),"^",5))
- .I PRMW'="" S $P(^PS(52.5,PRSP,0),"^",4)=PRMW D
- ..I PRFILL="P" D Q
- ...I $D(^PSRX(PRSDA,"P",+$G(PRFILLN),0)) S $P(^PSRX(PRSDA,"P",+$G(PRFILLN),0),"^",2)=$G(PRPSRX),$P(^PSRX(PRSDA,"MP"),"^")=PRMP
- ..I PRFILL="R",$G(PRFILLN) S DA(1)=PRSDA,DA=PRFILLN,DIE="^PSRX("_DA(1)_",1,",DR="2////"_PRPSRX D ^DIE K DIE
- ..I PRFILL="O" S DA=PRSDA,DIE="^PSRX(",DR="11////"_PRPSRX D ^DIE K DIE
- ..S $P(^PSRX(PRSDA,"MP"),"^")=PRMP
- Q
- PAUSE ;
- W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
- Q
- PSOSUPAT ;BIR/RTR-Pull all Rx's from suspense for a patient ;03/01/96
- +1 ;;7.0;OUTPATIENT PHARMACY;**8,130,185**;DEC 1997
- +2 ;External reference to ^PS(55 supported by DBIA 2228
- +3 ;External reference to ^PSSLOCK supported by DBIA 2789
- PAT NEW PSOALRX,PSOALRXS
- SET POP=0
- KILL RXP,RXRR,RXFL,RXRP,RXPR,ASKED,BC,DELCNT,WARN,PSOAL,PSOPROFL,PSOQFLAG,PSOPULL,PSOWIN,PSOWINEN,PPLHOLD,PPLHOLDX
- WRITE !
- SET DIR("A")="Are you entering the patient name or barcode"
- SET DIR(0)="SBO^P:Patient Name;B:Barcode"
- +1 SET DIR("?")="Enter P if you are going to enter the patient name. Enter B if you are going to enter or wand the barcode."
- +2 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO ^PSOSUPRX
- SET BC=Y
- DO NOW^%DTC
- SET TM=$EXTRACT(%,1,12)
- SET TM1=$PIECE(TM,".",2)
- BC SET (OUT,POP)=0
- IF BC="B"
- WRITE !
- SET DIR("A")="Enter/wand barcode"
- SET DIR(0)="FO^5:20"
- SET DIR("?")="Enter or wand a prescription barcode for the patient you wish to pull all Rx's for"
- DO ^DIR
- KILL DIR
- IF $GET(DIRUT)
- GOTO PAT
- SET BCNUM=Y
- Begin DoDot:1
- +1 DO PSOINST
- IF OUT
- QUIT
- SET RX=$PIECE(BCNUM,"-",2)
- KILL RTE
- SET MW=""
- IF $DATA(^PSRX(RX,0))
- Begin DoDot:2
- +2 SET (DFN,PSODFN)=$PIECE(^PSRX(RX,0),"^",2)
- WRITE " ",$PIECE($GET(^DPT(DFN,0)),"^")
- +3 DO ICN^PSODPT(DFN)
- End DoDot:2
- +4 IF '$DATA(^PSRX(RX,0))
- WRITE !,$CHAR(7),"NO PRESCRIPTION RECORD FOR THIS BARCODE."
- SET OUT=1
- End DoDot:1
- +5 IF OUT
- GOTO BC
- NAM IF BC="P"
- WRITE !
- SET DIC(0)="AEMZQ"
- SET DIC="^DPT("
- SET DIC("S")="I $D(^PS(52.5,""AC"",+Y))!($D(^PS(52.5,""AG"",+Y)))"
- DO ^DIC
- KILL DIC
- IF $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
- GOTO PAT
- SET (DFN,PSODFN)=+Y
- KILL RTE
- SET MW=""
- +1 SET PSOLOUD=1
- IF $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
- DO EN^PSOHLUP(PSODFN)
- KILL PSOLOUD
- +2 SET (ASKED,DELCNT,WARN)=0
- FOR CBD=0:0
- SET CBD=$ORDER(^PS(55,DFN,"P",CBD))
- IF CBD'>0
- QUIT
- DO TEST
- +3 IF $GET(PSOQFLAG)
- DO RESET
- GOTO EXIT
- +4 ;S HOLDPROF=$G(PSOPROFL) K PSOPROFL
- +5 ;I $D(PSOPART) S (PSOPULL,PSODBQ)=1 F RR=0:0 S RR=$O(PSOPART(RR)) Q:'RR S PDUZ=DUZ,PPL=RR,RXP=PSOPART(RR) D Q^PSORXL
- +6 ;S PSOPROFL=HOLDPROF I $D(ZTSK),'$G(PPLHOLD) W !!,"LABEL(S) ARE QUEUED TO PRINT",!
- +7 FOR GGGG=0:0
- SET GGGG=$ORDER(RXPR(GGGG))
- IF 'GGGG
- QUIT
- IF '$GET(RXPR(GGGG))
- KILL RXPR(GGGG)
- +8 KILL RXP,PPL
- SET PDUZ=DUZ
- SET PSONOPRT=1
- +9 IF $GET(PPLHOLD)'=""
- SET PPL=PPLHOLD
- IF $GET(SUSROUTE)
- SET BBRX(1)=PPL
- SET HOLDPPL=PPL
- SET PSOPULL=1
- SET PSODBQ=1
- SET RXLTOP=1
- DO WIND^PSOSUPRX
- DO Q^PSORXL
- IF '$GET(PSOQFLAG)
- WRITE !!,"LABEL(S) ARE QUEUED TO PRINT",!
- SET PPL=$PIECE(HOLDPPL,",")
- DO PRF
- IF '$GET(PSOQFLAG)
- Begin DoDot:1
- +10 IF $PIECE(PSOPAR,"^",8)
- IF $GET(PSOPROFL)
- WRITE !!,"PROFILE(S) ARE QUEUED TO PRINT"
- End DoDot:1
- SET PSOQFLAG=0
- +11 ;call to bingo board
- +12 IF $GET(PPLHOLDX)
- IF '$GET(PSOQGLAG)
- IF $GET(SUSROUTE)
- SET BBRX(2)=PPLHOLDX
- +13 IF $GET(BINGRTE)&($DATA(DISGROUP))&('$GET(PSOQFLAG))
- DO ^PSOBING1
- KILL BINGRTE,BBRX
- +14 IF $GET(PPLHOLDX)
- IF '$GET(PSOQFLAG)
- Begin DoDot:1
- +15 FOR XXX=0:0
- SET XXX=$ORDER(RXPR1(XXX))
- IF 'XXX
- QUIT
- SET RXPR(XXX)=$PIECE(RXPR1(XXX),"^",2)
- +16 FOR WWWW=0:0
- SET WWWW=$ORDER(RXRP1(WWWW))
- IF 'WWWW
- QUIT
- IF $DATA(RXRP1(WWWW))
- SET RXRP(WWWW)=1
- End DoDot:1
- SET PDUZ=DUZ
- SET PPL=PPLHOLDX
- SET PSNP=0
- SET (PSODBQ,PSOPULL)=1
- DO Q^PSORXL
- +17 IF $GET(PSOQFLAG)
- DO RESET
- EXIT KILL ACT,BCNUM,CBD,CNT,COM,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,DTTM,GG,HOLD,HOLDPPL,HDSFN,OUT,PSOPULL,PSOWIN,PSOWINEN,PSODBQ,PPLHOLD,PPLHOLDX,HOLDPROF,RR,ZZZZ,PSDNAME,PSDDDATE,ZTSK,WWWW,RXRP,RXRP1,PSONOPRT,RXFL,RXRR
- +1 SET PSOALRX=""
- FOR
- SET PSOALRX=$ORDER(PSOALRXS(PSOALRX))
- IF PSOALRX=""
- QUIT
- DO PSOUL^PSSLOCK(PSOALRX)
- +2 KILL MW,PDUZ,PPL,PRF,PSPOP,PSOPROFL,RF,RFCNT,RX,RXPR,RXPR1,RXREC,SFN,GGGG,STOP,SUB,VADM,WARN,X,Y,Y(0),%,%W,%Y,%Y1,RXLTOP,PSOGET,PSOGETF,PSOGETFN
- QUIT
- TEST IF $DATA(^PS(55,DFN,"P",CBD,0))
- SET RXREC=+^(0)
- IF +$PIECE($GET(^PSRX(RXREC,"STA")),"^")=5
- IF $DATA(^PS(52.5,"B",RXREC))
- SET SFN=+$ORDER(^(RXREC,0))
- IF SFN'>0!($GET(PSOQFLAG))!('$DATA(^PS(52.5,SFN,0)))
- QUIT
- SET PSPOP=0
- IF $GET(PSODIV)
- DO DIV
- IF 'PSPOP
- DO CHKDEAD
- IF DEAD
- QUIT
- DO BEG
- +1 QUIT
- CHKDEAD DO DEM^VADPT
- SET PSDNAME=$GET(VADM(1))
- IF VADM(1)=""
- WRITE !?10,"PATIENT NAME UNKNOWN"
- SET DEAD=0
- QUIT
- +1 IF VADM(6)=""
- SET DEAD=0
- QUIT
- +2 SET PSDDDATE=$PIECE(VADM(6),"^",2)
- FOR ZZZZ=0:0
- SET ZZZZ=$ORDER(^PS(55,DFN,"P",ZZZZ))
- IF 'ZZZZ
- QUIT
- IF $DATA(^PS(55,DFN,"P",ZZZZ,0))
- IF $PIECE($GET(^(0)),"^")
- SET (DA,RXREC)=$PIECE(^(0),"^")
- IF $ORDER(^PS(52.5,"B",DA,0))
- DO DEAD
- +3 QUIT
- DEAD SET HOLD=DA
- SET REA="C"
- SET COM="Died ("_$GET(PSDDDATE)_")"
- SET DA=RXREC
- SET DEAD=1
- DO CAN^PSOCAN
- IF '$GET(WARN)
- WRITE !!,?10,$GET(PSDNAME)," DIED ",$GET(PSDDDATE)
- SET WARN=1
- SET DA=HOLD
- KILL HOLD,REA
- QUIT
- DIV IF $DATA(^PS(52.5,SFN,0))
- IF $DATA(^PSRX(+$PIECE(^PS(52.5,SFN,0),"^"),2))
- IF $PIECE(^PS(52.5,SFN,0),"^",6)'=$GET(PSOSITE)
- SET RXREC=+$PIECE(^PS(52.5,SFN,0),"^")
- DO CKDIV
- +1 QUIT
- CKDIV IF '$PIECE($GET(PSOSYS),"^",2)
- WRITE !!?10,$CHAR(7),"Rx # ",$PIECE(^PSRX(RXREC,0),"^")," is not a valid choice. (Different Division)"
- SET PSPOP=1
- QUIT
- +1 IF $PIECE($GET(PSOSYS),"^",3)
- WRITE !!?10,$CHAR(7)
- SET DIR("A")="Rx # "_$PIECE(^PSRX(RXREC,0),"^")_" is from another division. Continue"
- SET DIR(0)="Y"
- SET DIR("B")="Y"
- DO ^DIR
- KILL DIR
- IF $GET(DIRUT)!('Y)
- SET PSPOP=1
- +2 QUIT
- BEG IF $PIECE($GET(^PSRX(RXREC,2)),"^",6)<DT
- IF $PIECE($GET(^("STA")),"^")<11
- Begin DoDot:1
- +1 DO EX^PSOSUTL
- End DoDot:1
- SET DIE=52
- SET DA=RXREC
- SET DR="100///"_11
- DO ^DIE
- SET DA=SFN
- SET DIK="^PS(52.5,"
- DO ^DIK
- KILL DIE,DA,DIK
- WRITE !!,"Rx #"_$PIECE(^PSRX(RXREC,0),"^")_" has expired!"
- DO PAUSE
- QUIT
- +2 IF '$DATA(^PS(52.5,SFN,0))
- KILL PSOAL
- QUIT
- +3 IF +$GET(^PS(52.5,SFN,"P"))
- WRITE !!,$CHAR(7),">>> Rx #",$PIECE(^PSRX(+$PIECE(^(0),"^"),0),"^")_" has already been printed from suspense.",!,?5,"Use the reprint routine under the rx option to produce a label."
- DO PAUSE
- QUIT
- +4 SET PSOALRX=$PIECE($GET(^PS(52.5,SFN,0)),"^")
- IF PSOALRX
- DO PSOL^PSSLOCK(PSOALRX)
- IF '$GET(PSOMSG)
- Begin DoDot:1
- +5 IF $PIECE($GET(PSOMSG),"^",2)'=""
- WRITE !!,"Rx: "_$PIECE($GET(^PSRX(PSOALRX,0)),"^")_" cannot be pulled from suspense.",!,$PIECE($GET(PSOMSG),"^",2),!
- QUIT
- +6 WRITE !!,"Another person is editing Rx "_$PIECE($GET(^PSRX(PSOALRX,0)),"^"),!,"It cannot be pulled from suspense.",!
- End DoDot:1
- DO PAUSE
- KILL PSOMSG,PSOALRX
- QUIT
- +7 SET PSOALRXS(+$GET(PSOALRX))=""
- +8 KILL PSOMSG,PSOALRX
- +9 SET DA=$PIECE(^PS(52.5,SFN,0),"^")
- SET RXPR(DA)=+$PIECE(^(0),"^",5)
- SET RXFL(DA)=$PIECE($GET(^(0)),"^",13)
- +10 IF $LENGTH($GET(PPLHOLD))<240
- SET PPLHOLD=$SELECT($GET(PPLHOLD)="":$PIECE(^PS(52.5,SFN,0),"^"),1:$GET(PPLHOLD)_","_+^PS(52.5,SFN,0))
- IF $PIECE(^PS(52.5,SFN,0),"^",12)
- SET RXRP(DA)=1
- GOTO STR
- +11 SET PPLHOLDX=$SELECT($GET(PPLHOLDX)="":$PIECE(^PS(52.5,SFN,0),"^"),1:$GET(PPLHOLDX)_","_+^PS(52.5,SFN,0))
- IF $GET(RXPR(DA))
- SET RXPR1(DA)=DA_"^"_RXPR(DA)
- IF $PIECE(^PS(52.5,SFN,0),"^",12)
- SET RXRP1(DA)=1
- KILL RXPR(DA)
- STR IF '$DATA(^PSRX(RXREC,1))
- IF '$GET(RXPR(RXREC))
- IF '$GET(RXPR1(RXREC))
- SET PSOPROFL=1
- QUES SET HDSFN=SFN
- DO QUES^PSOSUPRX
- QUIT
- PRF IF $PIECE(PSOPAR,"^",8)
- IF '$DATA(PRF(DFN))
- IF $GET(PSOPROFL)
- SET HOLD=DFN
- DO ^PSOPRF
- SET DFN=HOLD
- SET PRF(DFN)=""
- +1 QUIT
- PSOINST IF '$DATA(^PSRX(+$PIECE(Y,"-",2),0))
- WRITE !!,$CHAR(7),"Non-existent prescription"
- SET OUT=1
- QUIT
- +1 IF $PIECE(Y,"-")'=PSOINST
- WRITE !!,$CHAR(7),"The prescription is not from this institution."
- SET OUT=1
- QUIT
- +2 QUIT
- MAIL IF $DATA(PSOWINEN)
- IF $GET(PSOWIN)
- SET ^PSRX(RXREC,"MP")=$SELECT(PSOWINEN'="":PSOWINEN,1:"")
- MAILS IF $GET(RXPR(RXREC))
- SET DA(1)=RXREC
- SET DA=RXPR(RXREC)
- SET DIE="^PSRX("_DA(1)_",""P"","
- SET DR=".02///"_MW
- DO ^DIE
- KILL DIE
- QUIT
- +1 SET RFCNT=0
- FOR RR=0:0
- SET RR=$ORDER(^PSRX(RXREC,1,RR))
- IF 'RR
- QUIT
- SET RFCNT=RR
- +2 IF 'RFCNT
- IF '$GET(RXPR(RXREC))
- SET DA=RXREC
- SET DIE=52
- SET DR="11///"_MW
- DO ^DIE
- +3 IF RFCNT
- IF '$GET(RXPR(RXREC))
- SET DA(1)=RXREC
- SET DA=RFCNT
- SET DIE="^PSRX("_DA(1)_",1,"
- SET DR="2///"_MW
- DO ^DIE
- +4 KILL DIE,RFCNT,RR
- QUIT
- RESET ;
- +1 NEW PRSDA,PRSP,PRMW,PRMP,PRFILL,PRFILLN,PRPSRX,DA
- +2 FOR PRSDA=0:0
- SET PRSDA=$ORDER(RXRR(PRSDA))
- IF 'PRSDA
- QUIT
- Begin DoDot:1
- +3 SET PRSP=$ORDER(^PS(52.5,"B",PRSDA,0))
- IF 'PRSP
- QUIT
- +4 IF '$DATA(^PS(52.5,PRSP,0))
- QUIT
- +5 SET PRMW=$SELECT($PIECE($GET(RXRR(PRSDA)),"^")="":"M",1:$PIECE($GET(RXRR(PRSDA)),"^"))
- SET PRMP=$PIECE($GET(RXRR(PRSDA)),"^",2)
- SET PRFILL=$PIECE($GET(RXRR(PRSDA)),"^",3)
- SET PRFILLN=$PIECE($GET(RXRR(PRSDA)),"^",4)
- SET PRPSRX=$SELECT($PIECE($GET(RXRR(PRSDA)),"^",5)="":"M",1:$PIECE($GET(RXRR(PRSDA)),"^",5))
- +6 IF PRMW'=""
- SET $PIECE(^PS(52.5,PRSP,0),"^",4)=PRMW
- Begin DoDot:2
- +7 IF PRFILL="P"
- Begin DoDot:3
- +8 IF $DATA(^PSRX(PRSDA,"P",+$GET(PRFILLN),0))
- SET $PIECE(^PSRX(PRSDA,"P",+$GET(PRFILLN),0),"^",2)=$GET(PRPSRX)
- SET $PIECE(^PSRX(PRSDA,"MP"),"^")=PRMP
- End DoDot:3
- QUIT
- +9 IF PRFILL="R"
- IF $GET(PRFILLN)
- SET DA(1)=PRSDA
- SET DA=PRFILLN
- SET DIE="^PSRX("_DA(1)_",1,"
- SET DR="2////"_PRPSRX
- DO ^DIE
- KILL DIE
- +10 IF PRFILL="O"
- SET DA=PRSDA
- SET DIE="^PSRX("
- SET DR="11////"_PRPSRX
- DO ^DIE
- KILL DIE
- +11 SET $PIECE(^PSRX(PRSDA,"MP"),"^")=PRMP
- End DoDot:2
- End DoDot:1
- +12 QUIT
- PAUSE ;
- +1 WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- KILL DIR
- +2 QUIT
