- PSORXRP1 ;BIR/SAB-rx speed reprint listman ;Aug 31, 2021
- ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148,367,641,441**;DEC 1997;Build 208
- ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
- SEL N PSODISP,PSOMGREP,VALMCNT,Y I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
- S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
- K PSOSUSID N CNT,LSTCNT,ORD,ORN,PSOOELSE,TMP
- S CNT=0
- I +LST S PSOOELSE=1 S LSTCNT=$L(LST,",") F ORD=1:1:LSTCNT Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD) I +$G(PSOLST(ORN))=52,$P($G(PSOLST(ORN)),U,3)="ACTIVE" D
- .N CHKPARK,LNG,ORD1,PSDRG,PSRX0,RXNUM,TMPLST
- .S CHKPARK=$P($G(PSOLST(+ORN)),"^",2) ;PAPI441
- .I CHKPARK'="",$G(^PSRX(CHKPARK,"PARK")),+$P($G(^PSRX(CHKPARK,"STA")),"^")=0 D
- ..S CNT=CNT+1,TMPLST=""
- ..S ORD1=0 I ORD>1 S ORD1=ORD-1
- ..S LNG=$L($P(LST,",",1,ORD))+2
- ..I ORD1>0 S TMPLST=$E(LST,1,$L($P(LST,",",1,ORD1)))
- ..I ORD<LSTCNT S TMPLST=$S($G(TMPLST)'="":TMPLST_",",1:"")_$E(LST,LNG,$L(LST))
- ..S LST=TMPLST
- ..S LSTCNT=LSTCNT-1,ORD=ORD-1
- ..;S VALMSG="Cannot Reprint! Medication is currently PARKED.",VALMBCK=""
- ..I CNT=1 D
- ...D FULL^VALM1
- ...;W !!,"Cannot Reprint! Medication is currently PARKED."
- ...;S VALMSG="Cannot Reprint! Medication is currently PARKED."
- ..;S X="" F S X=$O(PSOSD("ACTIVE",X)) Q:X="" I +PSOSD("ACTIVE",X)=+ORN D
- ..S PSRX0=$G(^PSRX(CHKPARK,0))
- ..S RXNUM=$P(PSRX0,U,1)
- ..S PSDRG=+$P(PSRX0,U,6)
- ..S PSDRG=$P($G(^PSDRUG(PSDRG,0)),U,1)
- ..;W !," #"_+ORN_" Rx #: "_RXNUM_" "_$G(PSDRG)
- ..S TMP("PSOSEL",(CNT+1))=" #"_+ORN_$E(" ",1,(6-$L(+ORN)))_"Rx #: "_RXNUM_$E(" ",1,(12-$L(RXNUM)))_$G(PSDRG)
- S Y=1
- I CNT>0 D
- .N LN
- .W !
- .S TMP("PSOSEL",1)="Cannot Reprint! Medication"_$S(CNT=1:" is",1:"s are")_" currently PARKED."
- .S LN=0 F S LN=$O(TMP("PSOSEL",LN)) Q:LN="" W !,$G(TMP("PSOSEL",LN))
- .W !!
- .N DIR,DIRUT,DUOUT
- .S DIR(0)="E" D ^DIR
- .W !!
- I Y=0 S (PSOOELSE,PSOREPX)=1 G SEL1
- K DIR,DIRUT,DTOUT,PSOREPX I +LST S PSOOELSE=1 D
- .I CNT=0 D FULL^VALM1
- .K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1
- .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S COPIES=Y
- .K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
- .S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S SIDE=Y
- .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D Q:$G(PSOREPX)
- ..K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
- ..D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1)
- .I $$GET1^DIQ(59,PSOSITE,134)'="" D Q:$D(DIRUT)
- ..K DIR,DIRUT S DIR("A")="Reprint the FDA Medication Guide",DIR(0)="Y",DIR("B")="No"
- ..D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S PSOMGREP=Y
- .K DIRUT,DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
- .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S (PCOM,PCOMX)=Y
- .S PSOCLC=DUZ
- .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX
- .S VALMBCK="R"
- I '+LST,CNT>0 D
- .S VALMBCK="R"
- .S VALMSG="Cannot Reprint! Medication"_$S(CNT=1:" is",1:"s are")_" currently PARKED."
- .;I CNT=1 S VALMSG="Cannot Reprint! Medication is currently PARKED."
- .;I CNT>1 S VALMSG="Cannot Reprint! Medications are currently PARKED."
- SEL1 I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted."
- K PSOREPX
- I '$G(PSOOELSE) S VALMBCK=""
- D ^PSOBUILD
- K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,LST,PSOSUSID D KVA^VADPT
- Q
- RX ;process reprint request
- Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11
- I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR D PAUSE^VALM1 Q
- ;PSO*7*641 Suspense warning msg
- S PSOSUSID=$O(^PS(52.5,"B",$P(PSOLST(ORN),"^",2),0))
- I PSOSUSID,'$G(^PS(52.5,PSOSUSID,"P")) D Q
- . W $C(7),!!,"#"_ORN_" Rx "_$P(^PSRX($P(PSOLST(ORN),U,2),0),U)_" MAY NOT BE PRINTED using this option" W !,"use SUSPENSE FUNCTIONS Options." K DIR D PAUSE^VALM1 Q
- S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q
- S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q
- S RXF=0,ZD(RX)=DT,REPRINT=1
- S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
- I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
- I $G(PSOMGREP)=1 S RXRP($P(PSOLST(ORN),"^",2),"MG")=1
- S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ S RXFL($P(PSOLST(ORN),"^",2))=ZZZ
- K ZZZ
- I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q
- F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
- I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_","
- E S PSORX("PSOL",PSOX2+1)=RX_","
- S ST="" D ACT1
- D ULR
- Q
- CHK ;check for valid reprint
- I DT>$P(^PSRX(RX,2),"^",6) D S QFLG=1 Q
- .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D
- ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM
- S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D S QFLG=1 Q
- .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
- .D ACT1
- I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q
- D VALID Q:$G(QFLG)
- S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q
- I $G(X)'>0 G GOOD
- I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD
- I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q
- I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q
- GOOD K X
- I $D(^PS(52.4,RX)) S QFLG=1 Q
- I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q
- I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q
- I STA=3!(STA=4)!(STA=12) S QFLG=1 Q
- Q
- ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1
- S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J S IR=J
- S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
- D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF
- S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1
- Q
- VALID ;check for rx in label array
- I $O(PSORX("PSOL",0)) D
- .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q
- Q
- ULR ;
- I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXRP1 7263 printed Feb 19, 2025@00:01:03 Page 2
- PSORXRP1 ;BIR/SAB-rx speed reprint listman ;Aug 31, 2021
- +1 ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148,367,641,441**;DEC 1997;Build 208
- +2 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
- SEL NEW PSODISP,PSOMGREP,VALMCNT,Y
- IF '$GET(PSOCNT)
- SET VALMSG="This patient has no Prescriptions!"
- SET VALMBCK=""
- QUIT
- +1 SET RXCNT=0
- KILL PSOFDR,DIR,DUOUT,DIRUT
- SET DIR("A")="Select Orders by number"
- SET DIR(0)="LO^1:"_PSOCNT
- DO ^DIR
- SET LST=Y
- IF $DATA(DTOUT)!($DATA(DUOUT))
- KILL DIR,DIRUT,DTOUT,DUOUT
- SET VALMBCK=""
- QUIT
- +2 KILL PSOSUSID
- NEW CNT,LSTCNT,ORD,ORN,PSOOELSE,TMP
- +3 SET CNT=0
- +4 IF +LST
- SET PSOOELSE=1
- SET LSTCNT=$LENGTH(LST,",")
- FOR ORD=1:1:LSTCNT
- if $PIECE(LST,",",ORD)']""
- QUIT
- SET ORN=$PIECE(LST,",",ORD)
- IF +$GET(PSOLST(ORN))=52
- IF $PIECE($GET(PSOLST(ORN)),U,3)="ACTIVE"
- Begin DoDot:1
- +5 NEW CHKPARK,LNG,ORD1,PSDRG,PSRX0,RXNUM,TMPLST
- +6 ;PAPI441
- SET CHKPARK=$PIECE($GET(PSOLST(+ORN)),"^",2)
- +7 IF CHKPARK'=""
- IF $GET(^PSRX(CHKPARK,"PARK"))
- IF +$PIECE($GET(^PSRX(CHKPARK,"STA")),"^")=0
- Begin DoDot:2
- +8 SET CNT=CNT+1
- SET TMPLST=""
- +9 SET ORD1=0
- IF ORD>1
- SET ORD1=ORD-1
- +10 SET LNG=$LENGTH($PIECE(LST,",",1,ORD))+2
- +11 IF ORD1>0
- SET TMPLST=$EXTRACT(LST,1,$LENGTH($PIECE(LST,",",1,ORD1)))
- +12 IF ORD<LSTCNT
- SET TMPLST=$SELECT($GET(TMPLST)'="":TMPLST_",",1:"")_$EXTRACT(LST,LNG,$LENGTH(LST))
- +13 SET LST=TMPLST
- +14 SET LSTCNT=LSTCNT-1
- SET ORD=ORD-1
- +15 ;S VALMSG="Cannot Reprint! Medication is currently PARKED.",VALMBCK=""
- +16 IF CNT=1
- Begin DoDot:3
- +17 DO FULL^VALM1
- +18 ;W !!,"Cannot Reprint! Medication is currently PARKED."
- +19 ;S VALMSG="Cannot Reprint! Medication is currently PARKED."
- End DoDot:3
- +20 ;S X="" F S X=$O(PSOSD("ACTIVE",X)) Q:X="" I +PSOSD("ACTIVE",X)=+ORN D
- +21 SET PSRX0=$GET(^PSRX(CHKPARK,0))
- +22 SET RXNUM=$PIECE(PSRX0,U,1)
- +23 SET PSDRG=+$PIECE(PSRX0,U,6)
- +24 SET PSDRG=$PIECE($GET(^PSDRUG(PSDRG,0)),U,1)
- +25 ;W !," #"_+ORN_" Rx #: "_RXNUM_" "_$G(PSDRG)
- +26 SET TMP("PSOSEL",(CNT+1))=" #"_+ORN_$EXTRACT(" ",1,(6-$LENGTH(+ORN)))_"Rx #: "_RXNUM_$EXTRACT(" ",1,(12-$LENGTH(RXNUM)))_$GET(PSDRG)
- End DoDot:2
- End DoDot:1
- +27 SET Y=1
- +28 IF CNT>0
- Begin DoDot:1
- +29 NEW LN
- +30 WRITE !
- +31 SET TMP("PSOSEL",1)="Cannot Reprint! Medication"_$SELECT(CNT=1:" is",1:"s are")_" currently PARKED."
- +32 SET LN=0
- FOR
- SET LN=$ORDER(TMP("PSOSEL",LN))
- if LN=""
- QUIT
- WRITE !,$GET(TMP("PSOSEL",LN))
- +33 WRITE !!
- +34 NEW DIR,DIRUT,DUOUT
- +35 SET DIR(0)="E"
- DO ^DIR
- +36 WRITE !!
- End DoDot:1
- +37 IF Y=0
- SET (PSOOELSE,PSOREPX)=1
- GOTO SEL1
- +38 KILL DIR,DIRUT,DTOUT,PSOREPX
- IF +LST
- SET PSOOELSE=1
- Begin DoDot:1
- +39 IF CNT=0
- DO FULL^VALM1
- +40 KILL DIR
- SET DIR("A")="Number of Copies? "
- SET DIR(0)="N^1:99:0"
- SET DIR("?")="Enter the number of copies you want (1 TO 99)"
- SET DIR("B")=1
- +41 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- SET PSOREPX=1
- if $DATA(DIRUT)
- QUIT
- SET COPIES=Y
- +42 KILL DIR
- SET DIR("A")="Print adhesive portion of label only? "
- SET DIR(0)="Y"
- SET DIR("B")="No"
- SET DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
- +43 SET DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES."
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- SET PSOREPX=1
- if $DATA(DIRUT)
- QUIT
- SET SIDE=Y
- +44 IF $PIECE(PSOPAR,"^",30)
- IF $$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4
- Begin DoDot:2
- +45 KILL DIR,DIRUT
- SET DIR("A")="Do you want to resend to Dispensing System Device"
- SET DIR(0)="Y"
- SET DIR("B")="No"
- +46 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- SET PSOREPX=1
- if $DATA(DIRUT)
- QUIT
- SET PSODISP=$SELECT(Y:0,1:1)
- End DoDot:2
- if $GET(PSOREPX)
- QUIT
- +47 IF $$GET1^DIQ(59,PSOSITE,134)'=""
- Begin DoDot:2
- +48 KILL DIR,DIRUT
- SET DIR("A")="Reprint the FDA Medication Guide"
- SET DIR(0)="Y"
- SET DIR("B")="No"
- +49 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- SET PSOREPX=1
- if $DATA(DIRUT)
- QUIT
- SET PSOMGREP=Y
- End DoDot:2
- if $DATA(DIRUT)
- QUIT
- +50 KILL DIRUT,DIR
- SET DIR("A")="Comments: "
- SET DIR(0)="FA^5:60"
- SET DIR("?")="5-60 characters input required for activity log."
- if $GET(PCOMX)]""
- SET DIR("B")=$GET(PCOMX)
- +51 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- SET PSOREPX=1
- if $DATA(DIRUT)
- QUIT
- SET (PCOM,PCOMX)=Y
- +52 SET PSOCLC=DUZ
- +53 FOR ORD=1:1:$LENGTH(LST,",")
- if $PIECE(LST,",",ORD)']""
- QUIT
- SET ORN=$PIECE(LST,",",ORD)
- SET QFLG=0
- if +PSOLST(ORN)=52
- DO RX
- +54 SET VALMBCK="R"
- End DoDot:1
- +55 IF '+LST
- IF CNT>0
- Begin DoDot:1
- +56 SET VALMBCK="R"
- +57 SET VALMSG="Cannot Reprint! Medication"_$SELECT(CNT=1:" is",1:"s are")_" currently PARKED."
- +58 ;I CNT=1 S VALMSG="Cannot Reprint! Medication is currently PARKED."
- +59 ;I CNT>1 S VALMSG="Cannot Reprint! Medications are currently PARKED."
- End DoDot:1
- SEL1 IF $GET(PSOREPX)
- SET VALMBCK="R"
- SET VALMSG="No Labels Reprinted."
- +1 KILL PSOREPX
- +2 IF '$GET(PSOOELSE)
- SET VALMBCK=""
- +3 DO ^PSOBUILD
- +4 KILL PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,LST,PSOSUSID
- DO KVA^VADPT
- +5 QUIT
- RX ;process reprint request
- +1 if $PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA"),"^")>11
- QUIT
- +2 IF $$LMREJ^PSOREJU1($PIECE(PSOLST(ORN),"^",2))
- WRITE $CHAR(7),!!,"Rx "_$$GET1^DIQ(52,$PIECE(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!"
- KILL DIR
- DO PAUSE^VALM1
- QUIT
- +3 ;PSO*7*641 Suspense warning msg
- +4 SET PSOSUSID=$ORDER(^PS(52.5,"B",$PIECE(PSOLST(ORN),"^",2),0))
- +5 IF PSOSUSID
- IF '$GET(^PS(52.5,PSOSUSID,"P"))
- Begin DoDot:1
- +6 WRITE $CHAR(7),!!,"#"_ORN_" Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),U,2),0),U)_" MAY NOT BE PRINTED using this option"
- WRITE !,"use SUSPENSE FUNCTIONS Options."
- KILL DIR
- DO PAUSE^VALM1
- QUIT
- End DoDot:1
- QUIT
- +7 SET PSORPSRX=$PIECE(PSOLST(ORN),"^",2)
- DO PSOL^PSSLOCK(PSORPSRX)
- IF '$GET(PSOMSG)
- WRITE $CHAR(7),!!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing Rx "_$PIECE($GET(^PSRX(PSORPSRX,0)),"^")),!
- DO PAUSE^VALM1
- KILL PSORPSRX,PSOMSG
- QUIT
- +8 SET RX=$PIECE(PSOLST(ORN),"^",2)
- SET STA=$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA"),"^")
- DO CHK
- IF $GET(QFLG)
- DO ULR
- QUIT
- +9 SET RXF=0
- SET ZD(RX)=DT
- SET REPRINT=1
- +10 SET RXRP($PIECE(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
- +11 IF $GET(PSODISP)=1
- SET RXRP($PIECE(PSOLST(ORN),"^",2),"RP")=1
- +12 IF $GET(PSOMGREP)=1
- SET RXRP($PIECE(PSOLST(ORN),"^",2),"MG")=1
- +13 SET RXFL($PIECE(PSOLST(ORN),"^",2))=0
- FOR ZZZ=0:0
- SET ZZZ=$ORDER(^PSRX($PIECE(PSOLST(ORN),"^",2),1,ZZZ))
- if 'ZZZ
- QUIT
- SET RXFL($PIECE(PSOLST(ORN),"^",2))=ZZZ
- +14 KILL ZZZ
- +15 IF $GET(PSORX("PSOL",1))']""
- SET PSORX("PSOL",1)=RX_","
- SET ST=""
- DO ACT1
- DO ULR
- QUIT
- +16 FOR PSOX1=0:0
- SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
- if 'PSOX1
- QUIT
- SET PSOX2=PSOX1
- +17 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(RX)<220
- SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_","
- +18 IF '$TEST
- SET PSORX("PSOL",PSOX2+1)=RX_","
- +19 SET ST=""
- DO ACT1
- +20 DO ULR
- +21 QUIT
- CHK ;check for valid reprint
- +1 IF DT>$PIECE(^PSRX(RX,2),"^",6)
- Begin DoDot:1
- +2 IF $PIECE(^PSRX(RX,"STA"),"^")<11
- SET $PIECE(^PSRX(RX,"STA"),"^")=11
- Begin DoDot:2
- +3 SET COMM="Medication Expired on "_$EXTRACT($PIECE(^PSRX(RX,2),6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
- DO EN^PSOHLSN1(RX,"SC","ZE",COMM)
- KILL COMM
- End DoDot:2
- End DoDot:1
- SET QFLG=1
- QUIT
- +4 SET DFN=PSODFN
- DO DEM^VADPT
- IF $PIECE(VADM(6),"^",2)]""
- Begin DoDot:1
- +5 SET $PIECE(^PSRX(RX,"STA"),"^")=12
- SET PCOM="Patient Expired "_$PIECE(VADM(6),"^",2)
- SET ST="C"
- DO EN^PSOHLSN1(RX,"OD","",PCOM,"A")
- +6 DO ACT1
- End DoDot:1
- SET QFLG=1
- QUIT
- +7 IF $DATA(RXPR($PIECE(PSOLST(ORN),"^",2)))!$DATA(RXRP($PIECE(PSOLST(ORN),"^",2)))
- SET QFLG=1
- QUIT
- +8 DO VALID
- if $GET(QFLG)
- QUIT
- +9 SET X=$ORDER(^PS(52.5,"B",RX,0))
- IF X
- IF '$GET(^PS(52.5,X,"P"))
- SET QFLG=1
- QUIT
- +10 IF $GET(X)'>0
- GOTO GOOD
- +11 IF $PIECE($GET(^PS(52.5,X,0)),"^",7)']""
- GOTO GOOD
- +12 IF $PIECE($GET(^PS(52.5,X,0)),"^",7)="Q"
- KILL X,XX
- SET QFLG=1
- QUIT
- +13 IF $PIECE($GET(^PS(52.5,X,0)),"^",7)="L"
- KILL X,XX
- SET QFLG=1
- QUIT
- GOOD KILL X
- +1 IF $DATA(^PS(52.4,RX))
- SET QFLG=1
- QUIT
- +2 IF $DATA(^PS(52.4,"AREF",PSODFN,RX))
- SET QFLG=1
- QUIT
- +3 IF $GET(PSODIV)
- IF $DATA(^PSRX(RX,2))
- IF +$PIECE(^(2),"^",9)
- IF +$PIECE(^(2),"^",9)'=PSOSITE
- SET PSPOP=0
- SET PSPRXN=RX
- DO CHK1^PSOUTLA
- IF $GET(POERR)&(PSPOP)
- SET QFLG=1
- QUIT
- +4 IF STA=3!(STA=4)!(STA=12)
- SET QFLG=1
- QUIT
- +5 QUIT
- ACT1 SET RXF=0
- FOR J=0:0
- SET J=$ORDER(^PSRX(RX,1,J))
- if 'J
- QUIT
- SET RXF=J
- if J>5
- SET RXF=J+1
- +1 SET IR=0
- FOR J=0:0
- SET J=$ORDER(^PSRX(RX,"A",J))
- if 'J
- QUIT
- SET IR=J
- +2 SET IR=IR+1
- SET ^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
- +3 DO NOW^%DTC
- SET ^PSRX(RX,"A",IR,0)=%_"^"_$SELECT($GET(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$SELECT($GET(ST)'="C":" ("_COPIES_" COPIES)",1:"")
- SET PCOMX=PCOM
- KILL PC,IR,PS,XX,%,%H,%I,RXF
- +4 if $PIECE(^PSRX(RX,2),"^",15)&($GET(ST)'="C")
- SET $PIECE(^PSRX(RX,2),"^",14)=1
- +5 QUIT
- VALID ;check for rx in label array
- +1 IF $ORDER(PSORX("PSOL",0))
- Begin DoDot:1
- +2 FOR PSOX1=0:0
- SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
- if 'PSOX1
- QUIT
- IF PSORX("PSOL",PSOX1)[RX_","
- SET QFLG=1
- QUIT
- End DoDot:1
- +3 QUIT
- ULR ;
- +1 IF $GET(PSORPSRX)
- DO PSOUL^PSSLOCK(PSORPSRX)
- +2 QUIT
