- PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ;25-Feb-2013 15:01;DU
- ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,1013,156,185,280,1015**;DEC 1997;Build 62
- ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
- ;External reference ^PS(55 supported by DBIA 2228
- ;External reference to ^PSDRUG supported by DBIA 221
- ; Modified - IHS/CIA/PLS - 12/22/03 - Line GOOD+12, GOOD+31, and ACT+1
- ; Modified - IHS/CIA/DKM - 02/01/04 - Line ACT+3
- ; - IHS/MSC/PLS - 09/16/2011 - Line PSORXRP2+9,LRP+1,LRP+7
- ; Modified - IHS/MSC/MGH - 02/25/2013 - Line ACT1 + 5
- I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) G KILL
- Q:'$$ESIG^APSPFUNC ;IHS/MSC/PLS - patch 1013
- LRP N PSODISP
- ;K REPRINT W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10",DIC="^PSRX(",DIC("A")="Reprint Prescription Label: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) K PCOM,PCOMX G KILL
- K REPRINT W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<12",DIC="^PSRX(",DIC("A")="Reprint Prescription Label: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) K PCOM,PCOMX G KILL ;Changed to include expired
- S (PPL,DA,RX,PSORPRX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
- D PSOL^PSSLOCK(PSORPRX) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG G LRP
- I $P(^PSRX(RX,"STA"),"^")=14 W $C(7),!,"Cannot Reprint! Discontinued by Provider." D ULR,KILL Q
- I $P(^PSRX(RX,"STA"),"^")=15 W $C(7),!,"Cannot Reprint! Discontinued due to editing." D ULR,KILL Q
- I $P(^PSRX(RX,"STA"),"^")=16 W $C(7),!,"Cannot Reprint! Placed on HOLD by Provider." D ULR,KILL Q
- ;IHS/MSC/PLS - /2011 - Removed branch logic
- ;I DT>$P(^PSRX(RX,2),"^",6) D D ULR,KILL G LRP
- I DT>$P(^PSRX(RX,2),"^",6) D ;D ULR,KILL G LRP
- .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"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(DA,"SC","ZE",COMM) K COMM
- S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G LRP
- .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",!
- .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
- .D ACT1,ULR,KILL
- S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"Rx may NOT be printed using this option, use SUSPENSE FUNCTIONS Options." K X D ULR,KILL G LRP
- I $G(X)'>0 G GOOD
- S XX=$P($G(^PS(52.5,X,0)),U,7) I $G(XX)']"" G GOOD
- I $G(XX)="Q" W !,"RX CAN NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X,XX D ULR,KILL G LRP
- I $G(XX)="L" W !,"RX is being transmitted to the CMOP and can not be reprinted now." K X,XX D ULR,KILL G LRP
- GOOD K X
- I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! D ULR,KILL G LRP
- S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! D ULR,KILL G LRP
- I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA I PSPOP D ULR,KILL G LRP
- I STA=3 W !?3,"Prescription is on Hold" D ULR,KILL G LRP
- I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" D ULR,KILL G LRP
- I STA=12 W !?3,"Prescription is Discontinued" D ULR,KILL G LRP
- I $G(^PS(55,"ASTALK",DFN)) W !,"Patient is a ScripTalk patient. Use ScripTalk label for prescription bottle.",!
- D ICN^PSODPT(DFN)
- S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1)
- K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)"
- D ^DIR K DIR I $D(DIRUT) D ULR,KILL G LRP
- S COPIES=Y
- ; IHS/CIA/PLS - 12/22/03 - Suppress VA Label prompts
- ;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 I $D(DUOUT) D ULR,KILL G LRP
- ;I $D(DIRUT) D ULR G KILL
- S SIDE=0 ;Y - IHS/MSC/PLS - 5/14/10
- ; IHS/CIA/PLS - 12/22/03 - End Modifications
- I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D
- .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q
- .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 Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1)
- I $D(DIRUT) D ULR,KILL G LRP
- D ACT I $D(DIRUT) D ULR,KILL G LRP
- I $D(PCOM) D ULR,KILL G LRP
- F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I)
- S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN")
- W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
- I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D K D,FSIG
- .D FSIG^PSOUTLA("R",DA,75) F S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D))
- E D EN3^PSOUTLA1(DA,75) S D=0 F S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
- K D,BSIG
- ;PSO*7*280 If Trade name, don't lookup in ^PSDRUG
- W !!,$S($G(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
- W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
- I $G(RX) D
- .S RXRP(RX)=1_"^"_COPIES_"^"_SIDE
- .I $G(PSODISP)=1 S RXRP(RX,"RP")=1
- .S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ S RXFL(RX)=ZZZ
- ; IHS/CIA/PLS - 12/22/03 - Call IHS Label generator
- ;D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP,ZZZ,RXFL(+$G(RX)) D ULR,KILL G LRP
- D P^PSORXL K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP,ZZZ,RXFL(+$G(RX)) D ULR,KILL G LRP
- ;
- ACT ; IHS/CIA/PLS - 12/22/03 - Added 'O' to DIR(0)
- ;K 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)
- K DIR S DIR("A")="Comments: ",DIR(0)="FAO^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
- ; IHS/CIA/DKM - 02/01/04 - Null comment reprompts
- ;D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X
- D ^DIR K DIR Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) G:'$L(X) ACT S (PCOM,PCOMX)=X
- I '$D(PSOCLC) S PSOCLC=DUZ
- ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1
- S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J
- S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
- ;IHS/MSC/MGH variable APSPREIS added for reissue
- D NOW^%DTC S ^PSRX(DA,"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,PCOM,XX,%,%H,%I,RXF
- S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1
- Q
- ;
- KILL K %,DIR,DUOUT,DTOUT,DIROUT,DIRUT,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,ZD,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSXSTAT,PSORPRX,PSOMSG D KVA^VADPT Q
- ;
- ULR ;
- I $G(PSORPRX) D PSOUL^PSSLOCK(PSORPRX)
- Q
- PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ;25-Feb-2013 15:01;DU
- +1 ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,1013,156,185,280,1015**;DEC 1997;Build 62
- +2 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
- +3 ;External reference ^PS(55 supported by DBIA 2228
- +4 ;External reference to ^PSDRUG supported by DBIA 221
- +5 ; Modified - IHS/CIA/PLS - 12/22/03 - Line GOOD+12, GOOD+31, and ACT+1
- +6 ; Modified - IHS/CIA/DKM - 02/01/04 - Line ACT+3
- +7 ; - IHS/MSC/PLS - 09/16/2011 - Line PSORXRP2+9,LRP+1,LRP+7
- +8 ; Modified - IHS/MSC/MGH - 02/25/2013 - Line ACT1 + 5
- +9 IF '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- GOTO KILL
- +10 ;IHS/MSC/PLS - patch 1013
- IF '$$ESIG^APSPFUNC
- QUIT
- LRP NEW PSODISP
- +1 ;K REPRINT W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10",DIC="^PSRX(",DIC("A")="Reprint Prescription Label: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) K PCOM,PCOMX G KILL
- +2 ;Changed to include expired
- KILL REPRINT
- WRITE !!
- SET DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<12"
- SET DIC="^PSRX("
- SET DIC("A")="Reprint Prescription Label: "
- SET DIC(0)="QEAZ"
- DO ^DIC
- KILL P,DIC("A")
- IF Y<0!("^"[X)
- KILL PCOM,PCOMX
- GOTO KILL
- +3 SET (PPL,DA,RX,PSORPRX)=+Y
- SET PDA=Y(0)
- SET RXF=0
- SET ZD(DA)=DT
- SET REPRINT=1
- SET STA=+$GET(^PSRX(+Y,"STA"))
- +4 DO PSOL^PSSLOCK(PSORPRX)
- IF '$GET(PSOMSG)
- WRITE !!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order."),!
- KILL PSOMSG
- GOTO LRP
- +5 IF $PIECE(^PSRX(RX,"STA"),"^")=14
- WRITE $CHAR(7),!,"Cannot Reprint! Discontinued by Provider."
- DO ULR
- DO KILL
- QUIT
- +6 IF $PIECE(^PSRX(RX,"STA"),"^")=15
- WRITE $CHAR(7),!,"Cannot Reprint! Discontinued due to editing."
- DO ULR
- DO KILL
- QUIT
- +7 IF $PIECE(^PSRX(RX,"STA"),"^")=16
- WRITE $CHAR(7),!,"Cannot Reprint! Placed on HOLD by Provider."
- DO ULR
- DO KILL
- QUIT
- +8 ;IHS/MSC/PLS - /2011 - Removed branch logic
- +9 ;I DT>$P(^PSRX(RX,2),"^",6) D D ULR,KILL G LRP
- +10 ;D ULR,KILL G LRP
- IF DT>$PIECE(^PSRX(RX,2),"^",6)
- Begin DoDot:1
- +11 WRITE !,$CHAR(7),"Medication Expired on "_$EXTRACT($PIECE(^PSRX(RX,2),"^",6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
- IF $PIECE(^PSRX(DA,"STA"),"^")<11
- SET $PIECE(^PSRX(DA,"STA"),"^")=11
- Begin DoDot:2
- +12 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(DA,"SC","ZE",COMM)
- KILL COMM
- End DoDot:2
- End DoDot:1
- +13 SET DFN=$PIECE(PDA,"^",2)
- DO DEM^VADPT
- IF $PIECE(VADM(6),"^",2)]""
- Begin DoDot:1
- +14 WRITE $CHAR(7),!!,$PIECE(^DPT($PIECE(PDA,"^",2),0),"^")_" Died "_$PIECE(VADM(6),"^",2)_".",!
- +15 SET $PIECE(^PSRX(RX,"STA"),"^")=12
- SET PCOM="Patient Expired "_$PIECE(VADM(6),"^",2)
- SET ST="C"
- DO EN^PSOHLSN1(RX,"OD","",PCOM,"A")
- +16 DO ACT1
- DO ULR
- DO KILL
- End DoDot:1
- GOTO LRP
- +17 SET X=$ORDER(^PS(52.5,"B",DA,0))
- IF X
- IF '$GET(^PS(52.5,X,"P"))
- WRITE !,$CHAR(7),"Rx may NOT be printed using this option, use SUSPENSE FUNCTIONS Options."
- KILL X
- DO ULR
- DO KILL
- GOTO LRP
- +18 IF $GET(X)'>0
- GOTO GOOD
- +19 SET XX=$PIECE($GET(^PS(52.5,X,0)),U,7)
- IF $GET(XX)']""
- GOTO GOOD
- +20 IF $GET(XX)="Q"
- WRITE !,"RX CAN NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options."
- KILL X,XX
- DO ULR
- DO KILL
- GOTO LRP
- +21 IF $GET(XX)="L"
- WRITE !,"RX is being transmitted to the CMOP and can not be reprinted now."
- KILL X,XX
- DO ULR
- DO KILL
- GOTO LRP
- GOOD KILL X
- +1 IF $DATA(^PS(52.4,DA))
- WRITE !,"Prescription is Non-Verified",!!
- DO ULR
- DO KILL
- GOTO LRP
- +2 SET DFN=$PIECE(^PSRX(DA,0),"^",2)
- IF $DATA(^PS(52.4,"AREF",DFN,DA))
- WRITE !,"Prescription is waiting for others to be verified",!!
- DO ULR
- DO KILL
- GOTO LRP
- +3 IF $GET(PSODIV)
- IF $DATA(^PSRX(DA,2))
- IF +$PIECE(^(2),"^",9)
- IF +$PIECE(^(2),"^",9)'=PSOSITE
- SET PSPOP=0
- SET PSPRXN=DA
- DO CHK1^PSOUTLA
- IF PSPOP
- DO ULR
- DO KILL
- GOTO LRP
- +4 IF STA=3
- WRITE !?3,"Prescription is on Hold"
- DO ULR
- DO KILL
- GOTO LRP
- +5 IF STA=4
- WRITE !?3,"Prescription is Pending Due to Drug Interactions"
- DO ULR
- DO KILL
- GOTO LRP
- +6 IF STA=12
- WRITE !?3,"Prescription is Discontinued"
- DO ULR
- DO KILL
- GOTO LRP
- +7 IF $GET(^PS(55,"ASTALK",DFN))
- WRITE !,"Patient is a ScripTalk patient. Use ScripTalk label for prescription bottle.",!
- +8 DO ICN^PSODPT(DFN)
- +9 SET COPIES=$SELECT($PIECE(PDA,"^",18)]"":$PIECE(PDA,"^",18),1:1)
- +10 KILL DIR
- SET DIR("A")="Number of Copies? "
- SET DIR("B")=COPIES
- SET DIR(0)="N^1:99:0"
- SET DIR("?")="Enter the number of copies you want (1 TO 99)"
- +11 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- DO ULR
- DO KILL
- GOTO LRP
- +12 SET COPIES=Y
- +13 ; IHS/CIA/PLS - 12/22/03 - Suppress VA Label prompts
- +14 ;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."
- +15 ;S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G LRP
- +16 ;I $D(DIRUT) D ULR G KILL
- +17 ;Y - IHS/MSC/PLS - 5/14/10
- SET SIDE=0
- +18 ; IHS/CIA/PLS - 12/22/03 - End Modifications
- +19 IF $PIECE(PSOPAR,"^",30)
- IF $$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4
- Begin DoDot:1
- +20 IF $SELECT($PIECE(PSOPAR,"^",30)=3:1,$PIECE(PSOPAR,"^",30)=4:1,1:0)
- IF '$$GET1^DIQ(50,$PIECE(PDA,"^",6),28,"I")
- QUIT
- +21 KILL DIR,DIRUT
- SET DIR("A")="Do you want to resend to Dispensing System Device"
- SET DIR(0)="Y"
- SET DIR("B")="No"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- QUIT
- SET PSODISP=$SELECT(Y:0,1:1)
- End DoDot:1
- +22 IF $DATA(DIRUT)
- DO ULR
- DO KILL
- GOTO LRP
- +23 DO ACT
- IF $DATA(DIRUT)
- DO ULR
- DO KILL
- GOTO LRP
- +24 IF $DATA(PCOM)
- DO ULR
- DO KILL
- GOTO LRP
- +25 FOR I=1,2,4,6,7,9,13,16
- SET P(I)=$PIECE(PDA,"^",I)
- +26 SET P(6)=+P(6)
- IF $DATA(^PSRX(DA,"TN"))
- IF ^("TN")]""
- SET P(6)=^("TN")
- +27 WRITE !!,"Rx # "_P(1),?23,$EXTRACT(P(13),4,5)_"/"_$EXTRACT(P(13),6,7)_"/"_$EXTRACT(P(13),2,3),!,$SELECT($DATA(^DPT(+P(2),0)):$PIECE(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
- +28 IF $PIECE($GET(^PSRX(DA,"SIG")),"^",2)
- SET D=0
- Begin DoDot:1
- +29 DO FSIG^PSOUTLA("R",DA,75)
- FOR
- SET D=$ORDER(FSIG(D))
- WRITE !,FSIG(D)
- IF '$ORDER(FSIG(D))
- QUIT
- End DoDot:1
- KILL D,FSIG
- +30 IF '$TEST
- DO EN3^PSOUTLA1(DA,75)
- SET D=0
- FOR
- SET D=$ORDER(BSIG(D))
- WRITE !,BSIG(D)
- IF '$ORDER(BSIG(D))
- QUIT
- +31 KILL D,BSIG
- +32 ;PSO*7*280 If Trade name, don't lookup in ^PSDRUG
- +33 WRITE !!,$SELECT($GET(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$DATA(^PSDRUG(P(6),0)):$PIECE(^(0),"^"),1:P(6)),!
- SET PHYS=$SELECT($DATA(^VA(200,+P(4),0)):$PIECE(^(0),"^"),1:"Unknown")
- WRITE PHYS
- KILL PHYS
- +34 WRITE ?25,$SELECT($DATA(^VA(200,+P(16),0)):$PIECE(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$GET(P(9))
- +35 IF $GET(RX)
- Begin DoDot:1
- +36 SET RXRP(RX)=1_"^"_COPIES_"^"_SIDE
- +37 IF $GET(PSODISP)=1
- SET RXRP(RX,"RP")=1
- +38 SET RXFL(RX)=0
- FOR ZZZ=0:0
- SET ZZZ=$ORDER(^PSRX(RX,1,ZZZ))
- IF 'ZZZ
- QUIT
- SET RXFL(RX)=ZZZ
- End DoDot:1
- +39 ; IHS/CIA/PLS - 12/22/03 - Call IHS Label generator
- +40 ;D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP,ZZZ,RXFL(+$G(RX)) D ULR,KILL G LRP
- +41 DO P^PSORXL
- KILL PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP,ZZZ,RXFL(+$GET(RX))
- DO ULR
- DO KILL
- GOTO LRP
- +42 ;
- ACT ; IHS/CIA/PLS - 12/22/03 - Added 'O' to DIR(0)
- +1 ;K 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)
- +2 KILL DIR
- SET DIR("A")="Comments: "
- SET DIR(0)="FAO^5:60"
- SET DIR("?")="5-60 characters input required for activity log."
- IF $GET(PCOMX)]""
- SET DIR("B")=$GET(PCOMX)
- +3 ; IHS/CIA/DKM - 02/01/04 - Null comment reprompts
- +4 ;D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X
- +5 DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
- QUIT
- IF '$LENGTH(X)
- GOTO ACT
- SET (PCOM,PCOMX)=X
- +6 IF '$DATA(PSOCLC)
- SET PSOCLC=DUZ
- ACT1 SET RXF=0
- FOR J=0:0
- SET J=$ORDER(^PSRX(DA,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(DA,"A",J))
- IF 'J
- QUIT
- SET IR=J
- +2 SET IR=IR+1
- SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
- +3 ;IHS/MSC/MGH variable APSPREIS added for reissue
- +4 DO NOW^%DTC
- SET ^PSRX(DA,"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,PCOM,XX,%,%H,%I,RXF
- +5 IF $PIECE(^PSRX(DA,2),"^",15)&($GET(ST)'="C")
- SET $PIECE(^PSRX(DA,2),"^",14)=1
- +6 QUIT
- +7 ;
- KILL KILL %,DIR,DUOUT,DTOUT,DIROUT,DIRUT,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,ZD,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSXSTAT,PSORPRX,PSOMSG
- DO KVA^VADPT
- QUIT
- +1 ;
- ULR ;
- +1 IF $GET(PSORPRX)
- DO PSOUL^PSSLOCK(PSORPRX)
- +2 QUIT
