PSORXRP1 ;BIR/SAB-rx speed reprint listman ;25-Feb-2013 15:00;DU
;;7.0;OUTPATIENT PHARMACY;**11,27,120,1013,156,148,1015**;DEC 1997;Build 62
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
; Modified - IHS/MSC/PLS - 10/12/2011 - Line SEL+3
; IHS/MSC/MGH - 2/25/2013 - Line ACT1+5
SEL N PSODISP,VALMCNT 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 DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D
.I '$$ESIG^APSPFUNC S VALMBCK="" Q ;IHS/MSC/PLS - 10/12/2011 - Added call to validate esig
.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)
.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 $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,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN 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
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
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
;IHS/MSC/MGH variable APSPREIS added for reissue
D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(APSPREIS)=1:"Z",$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
PSORXRP1 ;BIR/SAB-rx speed reprint listman ;25-Feb-2013 15:00;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**11,27,120,1013,156,148,1015**;DEC 1997;Build 62
+2 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+3 ; Modified - IHS/MSC/PLS - 10/12/2011 - Line SEL+3
+4 ; IHS/MSC/MGH - 2/25/2013 - Line ACT1+5
SEL NEW PSODISP,VALMCNT
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 DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX
IF +LST
SET PSOOELSE=1
Begin DoDot:1
+3 ;IHS/MSC/PLS - 10/12/2011 - Added call to validate esig
IF '$$ESIG^APSPFUNC
SET VALMBCK=""
QUIT
+4 DO FULL^VALM1
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
+5 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSOREPX=1
IF $DATA(DIRUT)
QUIT
SET COPIES=Y
+6 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."
+7 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
+8 IF $PIECE(PSOPAR,"^",30)
IF $$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4
Begin DoDot:2
+9 KILL DIR,DIRUT
SET DIR("A")="Do you want to resend to Dispensing System Device"
SET DIR(0)="Y"
SET DIR("B")="No"
+10 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
+11 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)
+12 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSOREPX=1
IF $DATA(DIRUT)
QUIT
SET (PCOM,PCOMX)=Y
+13 SET PSOCLC=DUZ
+14 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
+15 SET VALMBCK="R"
End DoDot:1
+16 IF $GET(PSOREPX)
SET VALMBCK="R"
SET VALMSG="No Labels Reprinted."
+17 KILL PSOREPX
+18 IF '$GET(PSOOELSE)
SET VALMBCK=""
+19 DO ^PSOBUILD
+20 KILL PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN
DO KVA^VADPT
+21 QUIT
+22 ;
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 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
+4 SET RX=$PIECE(PSOLST(ORN),"^",2)
SET STA=$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA"),"^")
DO CHK
IF $GET(QFLG)
DO ULR
QUIT
+5 SET RXF=0
SET ZD(RX)=DT
SET REPRINT=1
+6 SET RXRP($PIECE(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
+7 IF $GET(PSODISP)=1
SET RXRP($PIECE(PSOLST(ORN),"^",2),"RP")=1
+8 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
+9 KILL ZZZ
+10 IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=RX_","
SET ST=""
DO ACT1
DO ULR
QUIT
+11 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
IF 'PSOX1
QUIT
SET PSOX2=PSOX1
+12 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(RX)<220
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_","
+13 IF '$TEST
SET PSORX("PSOL",PSOX2+1)=RX_","
+14 SET ST=""
DO ACT1
+15 DO ULR
+16 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 ;IHS/MSC/MGH variable APSPREIS added for reissue
+4 DO NOW^%DTC
SET ^PSRX(RX,"A",IR,0)=%_"^"_$SELECT($GET(APSPREIS)=1:"Z",$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
+5 IF $PIECE(^PSRX(RX,2),"^",15)&($GET(ST)'="C")
SET $PIECE(^PSRX(RX,2),"^",14)=1
+6 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
