PSODISP1 ;BHAM ISC/SAB,PDW - Rx released/unrelease report ;Dec 13, 2021@07:59:07
;;7.0;OUTPATIENT PHARMACY;**15,9,33,391,617,441**;DEC 1997;Build 208
;External reference to ^PS(59.7 supported by DBIA 694
;External reference to ^PSDRUG( supported by DBIA 221
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division must be selected!",! G EXIT
AC S (I,MUL)=0,SITE=PSOSITE,PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
F S I=$O(^PS(59,I)) Q:'I S MUL=MUL+1
W @IOF,!?15,"Report of Released and UnReleased Prescriptions",!
I $G(MUL)>1 D G:$D(STOP) EXIT
.W ! S DIR("?",1)="Your Site Parameter file shows multiple divisions.",DIR("A",1)="You are currently logged in under the "_$P(^PS(59,PSOSITE,0),"^",1)_" division."
.S DIR("A")="Do you want to select a different division",DIR("?")="Enter 'Y' to select a different division for this report.",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR S:$D(DIRUT) STOP=1
.I $G(Y)=1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEQM" D ^DIC K DIC I $D(DIRUT) S STOP=1 Q
.Q:Y<1 S SITE=+Y W !
W ! S DIR("B")="NO",DIR("A")="Do you want ONLY Unreleased Prescriptions",DIR("?")="Enter 'Y' for ONLY Unreleased Prescriptions",DIR(0)="Y" D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT)) EXIT S DUD=Y
;
CS ; ask CS selection criteria - store in DUD1
K DIR
S DIR(0)="SA^C:Controlled Substances Rxs Only;N:Non-controlled Substances Rxs Only;B:Both Controlled and Non-controlled Substance Rxs"
S DIR("B")="B",DIR("A")="Include (C)S Rx only, (N)on CS Rx only, or (B)oth (C/N/B): "
K DUD1 D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT)) EXIT
S DUD1=Y
I DUD1="C" D G:$D(DIRUT) EXIT K DIR,X,Y,I,J,K
.K DIR W !!,"Select controlled substance schedules"
.S DIR(0)="S^1:SCHEDULES I - II;2:SCHEDULES III - V;3:SCHEDULES I - V",DIR("A")="Select Schedule(s)",DIR("B")=3
.D ^DIR
.I +Y>0 S SCH=Y S I=$S(Y=2:3,1:1),J=$S(Y=1:2,1:5) F K=I:1:J S SCH(K)=""
W ! S %DT(0)=PSIN,X1=DT,X2=-30 D C^%DTC I X>PSIN S (BEGDT,Y)=X
E S (BEGDT,Y)=PSIN
X ^DD("DD") S BEG=Y,%DT("A")="Enter Start date: ",%DT("B")=BEG,%DT="AEPX",%DT(0)=PSIN D ^%DT G:"^"[$E(X) EXIT S (%DT(0),BEGDT)=Y
S Y=DT X ^DD("DD") S END=Y
S %DT("A")="Ending date: ",%DT("B")=END D ^%DT K %DT G:"^"[$E(X) EXIT S ENDDT=Y
S Y=ENDDT D DD^%DT S PEDATE=Y S Y=BEGDT D DD^%DT S PSDATE=Y
; ***
K IO("Q"),%ZIS,IOP,ZTSK S PSOION=ION,%ZIS("S")="I $E($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0)),1)=""P""",%ZIS="MQ",%ZIS("A")="Select a PRINTER: ",%ZIS("B")=""
D ^%ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
K PSOION I $D(IO("Q")) D G EXIT
.S ZTRTN="BC^PSODISP1",ZTDESC="Report of released & unreleased prescriptions",ZTSAVE("SCH(")=""
.F G="BEGDT","ENDDT","PSDATE","PEDATE","SITE","DUD","DUD1","PSXSYS","SCH" S:$D(@G) ZTSAVE(G)=""
.D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K ZTSK,IO("Q")
;
BC S PG=1,(REL,UNREL,CP)=0 U IO D HD,RPT
W !!,"& Indicates eRx Prescription" ; PSO-617
W !!,"# of Released Fills - "_REL_" # of Unreleased Fills - "_UNREL_" # of Copay Fills - "_CP
I $E($G(IOST),1,2)'["C-" W !,@IOF
EXIT D ^%ZISC K PG,LIN,G,REL,RPT,UNREL,BEG,BEGDT,END,ENDDT,DR,X,X1,X2,Y,REC,DIR,DIRUT,DUOUT,I,Y,RXN,NODE,PAR,BDT,PSX,PSXZ,SCH,CSDEA
K PSOLCMF,STOP,TYPE,UNDERL,ZTDESC,ZTRTN,ZTSAVE,DIC,XY,ND,DUD,DUD1,DTOUT,SITE,MUL,CP,PSIN,%DT,PSDATE,PEDATE S:$D(ZTQUEUED) ZTREQ="@" K ZTQUEUED
Q
RPT S ND="",RXN=0,BDT=BEGDT-1 F S BDT=$O(^PSRX("AD",BDT)) Q:'BDT!(BDT>ENDDT) F S RXN=$O(^PSRX("AD",BDT,RXN)) Q:'RXN F S ND=$O(^PSRX("AD",BDT,RXN,ND)) Q:ND="" S NODE=ND D I $Y+4>IOSL D HD
.Q:$G(^PSRX(RXN,0))']"" I $G(PSXSYS) K PSX D CMOP^PSOCMOPA
.Q:$G(^PSRX(RXN,0))']"" D @$S(NODE:"REF",1:"RPT2") K LB,LBLP
S (RXN,ND)=0,BDT=BEGDT-1 F S BDT=$O(^PSRX("ADP",BDT)) Q:'BDT!(BDT>ENDDT) F S RXN=$O(^PSRX("ADP",BDT,RXN)) Q:'RXN F S ND=$O(^PSRX("ADP",BDT,RXN,ND)) Q:'ND S NODE=ND D I $Y+4>IOSL D HD
.Q:$G(^PSRX(RXN,0))']"" S PAR=1 D REF K LB,LBLP
Q
RPT2 I $P($G(^PSRX(RXN,2)),"^",13),DUD Q
I $P($G(^PSRX(RXN,2)),"^",15)]"",'$P(^(2),"^",14) Q
I $P($G(^PSRX(RXN,2)),"^",9)'=SITE Q
S XY=$P(^PSRX(RXN,"STA"),"^") I (XY=3)!(XY=4)!(XY=13)!(XY=16) Q
S CSDEA=$$CSDEA(RXN) I CSDEA=0 Q ; quit if CS Criteria fails
S PARKED=0 I XY=0,$G(^PSRX(RXN,"PARK")) S PARKED=1 ;441 PAPI
; if eRx, prepend "& " to Rx # PSO-617
N ERXIND S ERXIND=$$ERXIEN^PSOERXUT(RXN)
I $P(^PSRX(RXN,2),"^",13) D QUIT
. W !,$S(ERXIND'="":"&",1:" "),$P(^PSRX(RXN,0),"^"),?16,$E($$GET1^DIQ(50,$P(^PSRX(RXN,0),"^",6),.01),1,30),?48,"0"
. S Y=$P(^PSRX(RXN,2),"^",13)
. W ?52,$P($$FMTE^XLFDT(Y,"2Z"),"@"),?62,$$SCH($P(CSDEA,"^",2))
. S REL=REL+1
. D CP1
I '$P(^PSRX(RXN,2),"^",13) D Q:('$G(LBLP)&($G(PSX(0))']"")) W !,$S(ERXIND'="":"&",1:" "),$P(^PSRX(RXN,0),"^"),?16,$E($$GET1^DIQ(50,$P(^PSRX(RXN,0),"^",6),.01),1,30),?48,"0",?62,$$SCH($P(CSDEA,"^",2)) S UNREL=UNREL+1 D CP1
.F LB=0:0 S LB=$O(^PSRX(RXN,"L",LB)) Q:'LB I '$P(^PSRX(RXN,"L",LB,0),"^",2),$P(^(0),"^",3)'["INTERACTION",'$P(^(0),"^",5) S LBLP=1 Q
Q
REF ;
I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",$S('$G(PAR):18,1:19)),DUD Q
I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",9)'=SITE Q
I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",16)]"" Q
S XY=$P(^PSRX(RXN,"STA"),"^") I (XY=3)!(XY=4)!(XY>12) Q
S CSDEA=$$CSDEA(RXN) I CSDEA=0 Q ; quit if CS Criteria fails
S PARKED=0 I XY=0,$G(^PSRX(RXN,"PARK")) S PARKED=1 ;441 PAPI
; if eRx, prepend "& " to Rx # PSO-617
N ERXIND S ERXIND=$$ERXIEN^PSOERXUT(RXN)
I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",$S('$G(PAR):18,1:19)) D G CP1
.W !,$S(ERXIND'="":"&",1:" "),$P(^PSRX(RXN,0),"^"),?16,$E($$GET1^DIQ(50,$P(^PSRX(RXN,0),"^",6),.01),1,30),?48,$S('$G(PAR):"",1:"P"),NODE S REL=REL+1
.S Y=$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",$S('$G(PAR):18,1:19)) W ?52,$P($$FMTE^XLFDT(Y,"2Z"),"@"),?62,$$SCH($P(CSDEA,"^",2))
I '$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",$S('$G(PAR):18,1:19)) S RPT=0 D Q:'RPT
.F LB=0:0 S LB=$O(^PSRX(RXN,"L",LB)) Q:'LB I $P(^PSRX(RXN,"L",LB,0),"^",2)=$S('$G(PAR):NODE,1:99-NODE) S LBLP=1 Q
.Q:('$G(LBLP)&($G(PSX(NODE))']""))
.D TEST Q:'$G(LBLP)&($G(PSOLCMF))
.S RPT=1 W !,$S(ERXIND'="":"&",1:" "),$P(^PSRX(RXN,0),"^"),?16,$E($$GET1^DIQ(50,$P(^PSRX(RXN,0),"^",6),.01),1,30),?48,$S('$G(PAR):"",1:"P"),NODE,?62,$$SCH($P(CSDEA,"^",2)) S UNREL=UNREL+1
CP1 I 'PARKED W ?68,$S(XY=1:"NV",XY=2:"Ref",XY=3!(XY=16):"HLD",XY=5:"SUSP",XY=10:"DONE",XY=11:"EXP",XY=12!(XY=14)!(XY=15):"DC",1:"ACT")
I PARKED W ?68,"PARKED" ;441 PAPI ADDED PARKED TO THESE TWO LINES
Q:$G(PAR) I $P($G(^PSRX(RXN,"IB")),"^") W ?77,"Y" S CP=CP+1
I $G(PSX(NODE))]"" W ?85,"Y",?95,$S(PSX(NODE)=0:"Transmitted",PSX(NODE)=1:"Dispensed",PSX(NODE)=2:"Retransmitted",PSX(NODE)=3:"Not Dispensed",1:"Unknown")
Q
;
HD W @IOF,?$S('DUD:17,1:20),$S('DUD:"Release/",1:"")_"Unreleased Report for "_$P(^PS(59,SITE,0),"^",1),!
I $G(DUD1)="N" W ?13,"Non-controlled Substance Prescriptions Only"
I $G(DUD1)="C" W ?8,"Controlled Substance Prescriptions (",$S(SCH=1:"Schedules I - II",SCH=2:"Schedules III - V",SCH=3:"Schedules I - V",1:"")_")"
W !?18,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!!,?47,"Fill/",?54,"Date",!,"Rx #",?16,"Drug",?47,"Ref#",?54,"Rel",?62,"Sch",?67,"Status",?75,"Copay " W:$G(PSXSYS) "CMOP CMOP Status" W ! F LIN=1:1:$S($G(PSXSYS):115,1:80) W "-"
W ! S PG=PG+1 Q
;
TEST ;
S (PSOLCMF,PSOLCMR)=0
F PSOLCR=0:0 S PSOLCR=$O(^PSRX(RXN,1,PSOLCR)) Q:'PSOLCR I $D(^(PSOLCR,0)) S PSOLCMR=PSOLCR
I '$G(PSOLCMR) G TESTX
F PSOLCR=0:0 S PSOLCR=$O(^PSRX(RXN,"A",PSOLCR)) Q:'PSOLCR!($G(PSOLCMF)) D
.Q:$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",2)'="I"
.I $G(PSOLCMR)<6 S:$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",4)=$G(PSOLCMR) PSOLCMF=1 Q
.S PSOLCMRZ=$G(PSOLCMR)+1 S:PSOLCMRZ=$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",4) PSOLCMF=1 K PSOLCMRZ Q
TESTX K PSOLCR,PSOLCMR
Q
CSDEA(X) ;CS Criteria .. returns a 1 if both DEA on drug & criteria 'N/C/B' are satisfied
N DEA,DRUGDA
S DRUGDA=$$GET1^DIQ(52,X,6,"I"),DEA=$$GET1^DIQ(50,DRUGDA,3)
I DUD1="B" Q 1_"^"_+DEA ;both CS & non CS (all)
;CS
I DUD1="C" Q $S('+DEA:0,'$D(SCH(+DEA)):0,1:1_"^"_+DEA)
;Non CS
I (+DEA<1)!(+DEA>5) Q 1_"^"_+DEA
Q 0
;
SCH(X) ;Schedule conversion
Q:+X<1 ""
Q $P("I^II^III^IV^V","^",X)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODISP1 8179 printed Dec 13, 2024@02:27:07 Page 2
PSODISP1 ;BHAM ISC/SAB,PDW - Rx released/unrelease report ;Dec 13, 2021@07:59:07
+1 ;;7.0;OUTPATIENT PHARMACY;**15,9,33,391,617,441**;DEC 1997;Build 208
+2 ;External reference to ^PS(59.7 supported by DBIA 694
+3 ;External reference to ^PSDRUG( supported by DBIA 221
+4 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,"Pharmacy Division must be selected!",!
GOTO EXIT
AC SET (I,MUL)=0
SET SITE=PSOSITE
SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
+1 FOR
SET I=$ORDER(^PS(59,I))
if 'I
QUIT
SET MUL=MUL+1
+2 WRITE @IOF,!?15,"Report of Released and UnReleased Prescriptions",!
+3 IF $GET(MUL)>1
Begin DoDot:1
+4 WRITE !
SET DIR("?",1)="Your Site Parameter file shows multiple divisions."
SET DIR("A",1)="You are currently logged in under the "_$PIECE(^PS(59,PSOSITE,0),"^",1)_" division."
+5 SET DIR("A")="Do you want to select a different division"
SET DIR("?")="Enter 'Y' to select a different division for this report."
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET STOP=1
+6 IF $GET(Y)=1
WRITE !
SET DIC("A")="Division: "
SET DIC=59
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
IF $DATA(DIRUT)
SET STOP=1
QUIT
+7 if Y<1
QUIT
SET SITE=+Y
WRITE !
End DoDot:1
if $DATA(STOP)
GOTO EXIT
+8 WRITE !
SET DIR("B")="NO"
SET DIR("A")="Do you want ONLY Unreleased Prescriptions"
SET DIR("?")="Enter 'Y' for ONLY Unreleased Prescriptions"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
SET DUD=Y
+9 ;
CS ; ask CS selection criteria - store in DUD1
+1 KILL DIR
+2 SET DIR(0)="SA^C:Controlled Substances Rxs Only;N:Non-controlled Substances Rxs Only;B:Both Controlled and Non-controlled Substance Rxs"
+3 SET DIR("B")="B"
SET DIR("A")="Include (C)S Rx only, (N)on CS Rx only, or (B)oth (C/N/B): "
+4 KILL DUD1
DO ^DIR
KILL DIR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
+5 SET DUD1=Y
+6 IF DUD1="C"
Begin DoDot:1
+7 KILL DIR
WRITE !!,"Select controlled substance schedules"
+8 SET DIR(0)="S^1:SCHEDULES I - II;2:SCHEDULES III - V;3:SCHEDULES I - V"
SET DIR("A")="Select Schedule(s)"
SET DIR("B")=3
+9 DO ^DIR
+10 IF +Y>0
SET SCH=Y
SET I=$SELECT(Y=2:3,1:1)
SET J=$SELECT(Y=1:2,1:5)
FOR K=I:1:J
SET SCH(K)=""
End DoDot:1
if $DATA(DIRUT)
GOTO EXIT
KILL DIR,X,Y,I,J,K
+11 WRITE !
SET %DT(0)=PSIN
SET X1=DT
SET X2=-30
DO C^%DTC
IF X>PSIN
SET (BEGDT,Y)=X
+12 IF '$TEST
SET (BEGDT,Y)=PSIN
+13 XECUTE ^DD("DD")
SET BEG=Y
SET %DT("A")="Enter Start date: "
SET %DT("B")=BEG
SET %DT="AEPX"
SET %DT(0)=PSIN
DO ^%DT
if "^"[$EXTRACT(X)
GOTO EXIT
SET (%DT(0),BEGDT)=Y
+14 SET Y=DT
XECUTE ^DD("DD")
SET END=Y
+15 SET %DT("A")="Ending date: "
SET %DT("B")=END
DO ^%DT
KILL %DT
if "^"[$EXTRACT(X)
GOTO EXIT
SET ENDDT=Y
+16 SET Y=ENDDT
DO DD^%DT
SET PEDATE=Y
SET Y=BEGDT
DO DD^%DT
SET PSDATE=Y
+17 ; ***
+18 KILL IO("Q"),%ZIS,IOP,ZTSK
SET PSOION=ION
SET %ZIS("S")="I $E($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0)),1)=""P"""
SET %ZIS="MQ"
SET %ZIS("A")="Select a PRINTER: "
SET %ZIS("B")=""
+19 DO ^%ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,PSOION
GOTO EXIT
+20 KILL PSOION
IF $DATA(IO("Q"))
Begin DoDot:1
+21 SET ZTRTN="BC^PSODISP1"
SET ZTDESC="Report of released & unreleased prescriptions"
SET ZTSAVE("SCH(")=""
+22 FOR G="BEGDT","ENDDT","PSDATE","PEDATE","SITE","DUD","DUD1","PSXSYS","SCH"
if $DATA(@G)
SET ZTSAVE(G)=""
+23 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report Queued to Print !!",!
KILL ZTSK,IO("Q")
End DoDot:1
GOTO EXIT
+24 ;
BC SET PG=1
SET (REL,UNREL,CP)=0
USE IO
DO HD
DO RPT
+1 ; PSO-617
WRITE !!,"& Indicates eRx Prescription"
+2 WRITE !!,"# of Released Fills - "_REL_" # of Unreleased Fills - "_UNREL_" # of Copay Fills - "_CP
+3 IF $EXTRACT($GET(IOST),1,2)'["C-"
WRITE !,@IOF
EXIT DO ^%ZISC
KILL PG,LIN,G,REL,RPT,UNREL,BEG,BEGDT,END,ENDDT,DR,X,X1,X2,Y,REC,DIR,DIRUT,DUOUT,I,Y,RXN,NODE,PAR,BDT,PSX,PSXZ,SCH,CSDEA
+1 KILL PSOLCMF,STOP,TYPE,UNDERL,ZTDESC,ZTRTN,ZTSAVE,DIC,XY,ND,DUD,DUD1,DTOUT,SITE,MUL,CP,PSIN,%DT,PSDATE,PEDATE
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ZTQUEUED
+2 QUIT
RPT SET ND=""
SET RXN=0
SET BDT=BEGDT-1
FOR
SET BDT=$ORDER(^PSRX("AD",BDT))
if 'BDT!(BDT>ENDDT)
QUIT
FOR
SET RXN=$ORDER(^PSRX("AD",BDT,RXN))
if 'RXN
QUIT
FOR
SET ND=$ORDER(^PSRX("AD",BDT,RXN,ND))
if ND=""
QUIT
SET NODE=ND
Begin DoDot:1
+1 if $GET(^PSRX(RXN,0))']""
QUIT
IF $GET(PSXSYS)
KILL PSX
DO CMOP^PSOCMOPA
+2 if $GET(^PSRX(RXN,0))']""
QUIT
DO @$SELECT(NODE:"REF",1:"RPT2")
KILL LB,LBLP
End DoDot:1
IF $Y+4>IOSL
DO HD
+3 SET (RXN,ND)=0
SET BDT=BEGDT-1
FOR
SET BDT=$ORDER(^PSRX("ADP",BDT))
if 'BDT!(BDT>ENDDT)
QUIT
FOR
SET RXN=$ORDER(^PSRX("ADP",BDT,RXN))
if 'RXN
QUIT
FOR
SET ND=$ORDER(^PSRX("ADP",BDT,RXN,ND))
if 'ND
QUIT
SET NODE=ND
Begin DoDot:1
+4 if $GET(^PSRX(RXN,0))']""
QUIT
SET PAR=1
DO REF
KILL LB,LBLP
End DoDot:1
IF $Y+4>IOSL
DO HD
+5 QUIT
RPT2 IF $PIECE($GET(^PSRX(RXN,2)),"^",13)
IF DUD
QUIT
+1 IF $PIECE($GET(^PSRX(RXN,2)),"^",15)]""
IF '$PIECE(^(2),"^",14)
QUIT
+2 IF $PIECE($GET(^PSRX(RXN,2)),"^",9)'=SITE
QUIT
+3 SET XY=$PIECE(^PSRX(RXN,"STA"),"^")
IF (XY=3)!(XY=4)!(XY=13)!(XY=16)
QUIT
+4 ; quit if CS Criteria fails
SET CSDEA=$$CSDEA(RXN)
IF CSDEA=0
QUIT
+5 ;441 PAPI
SET PARKED=0
IF XY=0
IF $GET(^PSRX(RXN,"PARK"))
SET PARKED=1
+6 ; if eRx, prepend "& " to Rx # PSO-617
+7 NEW ERXIND
SET ERXIND=$$ERXIEN^PSOERXUT(RXN)
+8 IF $PIECE(^PSRX(RXN,2),"^",13)
Begin DoDot:1
+9 WRITE !,$SELECT(ERXIND'="":"&",1:" "),$PIECE(^PSRX(RXN,0),"^"),?16,$EXTRACT($$GET1^DIQ(50,$PIECE(^PSRX(RXN,0),"^",6),.01),1,30),?48,"0"
+10 SET Y=$PIECE(^PSRX(RXN,2),"^",13)
+11 WRITE ?52,$PIECE($$FMTE^XLFDT(Y,"2Z"),"@"),?62,$$SCH($PIECE(CSDEA,"^",2))
+12 SET REL=REL+1
+13 DO CP1
End DoDot:1
QUIT
+14 IF '$PIECE(^PSRX(RXN,2),"^",13)
Begin DoDot:1
+15 FOR LB=0:0
SET LB=$ORDER(^PSRX(RXN,"L",LB))
if 'LB
QUIT
IF '$PIECE(^PSRX(RXN,"L",LB,0),"^",2)
IF $PIECE(^(0),"^",3)'["INTERACTION"
IF '$PIECE(^(0),"^",5)
SET LBLP=1
QUIT
End DoDot:1
if ('$GET(LBLP)&($GET(PSX(0))']""))
QUIT
WRITE !,$SELECT(ERXIND'="":"&",1:" "),$PIECE(^PSRX(RXN,0),"^"),?16,$EXTRACT($$GET1^DIQ(50,$PIECE(^PSRX(RXN,0),"^",6),.01),1,30),?48,"0",?62,$$SCH($PIECE(CSDEA,"^",2))
SET UNREL=UNREL+1
DO CP1
+16 QUIT
REF ;
+1 IF $PIECE($GET(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0)),"^",$SELECT('$GET(PAR):18,1:19))
IF DUD
QUIT
+2 IF $PIECE($GET(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0)),"^",9)'=SITE
QUIT
+3 IF $PIECE($GET(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0)),"^",16)]""
QUIT
+4 SET XY=$PIECE(^PSRX(RXN,"STA"),"^")
IF (XY=3)!(XY=4)!(XY>12)
QUIT
+5 ; quit if CS Criteria fails
SET CSDEA=$$CSDEA(RXN)
IF CSDEA=0
QUIT
+6 ;441 PAPI
SET PARKED=0
IF XY=0
IF $GET(^PSRX(RXN,"PARK"))
SET PARKED=1
+7 ; if eRx, prepend "& " to Rx # PSO-617
+8 NEW ERXIND
SET ERXIND=$$ERXIEN^PSOERXUT(RXN)
+9 IF $PIECE($GET(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0)),"^",$SELECT('$GET(PAR):18,1:19))
Begin DoDot:1
+10 WRITE !,$SELECT(ERXIND'="":"&",1:" "),$PIECE(^PSRX(RXN,0),"^"),?16,$EXTRACT($$GET1^DIQ(50,$PIECE(^PSRX(RXN,0),"^",6),.01),1,30),?48,$SELECT('$GET(PAR):"",1:"P"),NODE
SET REL=REL+1
+11 SET Y=$PIECE(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0),"^",$SELECT('$GET(PAR):18,1:19))
WRITE ?52,$PIECE($$FMTE^XLFDT(Y,"2Z"),"@"),?62,$$SCH($PIECE(CSDEA,"^",2))
End DoDot:1
GOTO CP1
+12 IF '$PIECE(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0),"^",$SELECT('$GET(PAR):18,1:19))
SET RPT=0
Begin DoDot:1
+13 FOR LB=0:0
SET LB=$ORDER(^PSRX(RXN,"L",LB))
if 'LB
QUIT
IF $PIECE(^PSRX(RXN,"L",LB,0),"^",2)=$SELECT('$GET(PAR):NODE,1:99-NODE)
SET LBLP=1
QUIT
+14 if ('$GET(LBLP)&($GET(PSX(NODE))']""))
QUIT
+15 DO TEST
if '$GET(LBLP)&($GET(PSOLCMF))
QUIT
+16 SET RPT=1
WRITE !,$SELECT(ERXIND'="":"&",1:" "),$PIECE(^PSRX(RXN,0),"^"),?16,$EXTRACT($$GET1^DIQ(50,$PIECE(^PSRX(RXN,0),"^",6),.01),1,30),?48,$SELECT('$GET(PAR):"",1:"P"),NODE,?62,$$SCH($PIECE(CSDEA,"^",2))
SET UNREL=UNREL+1
End DoDot:1
if 'RPT
QUIT
CP1 IF 'PARKED
WRITE ?68,$SELECT(XY=1:"NV",XY=2:"Ref",XY=3!(XY=16):"HLD",XY=5:"SUSP",XY=10:"DONE",XY=11:"EXP",XY=12!(XY=14)!(XY=15):"DC",1:"ACT")
+1 ;441 PAPI ADDED PARKED TO THESE TWO LINES
IF PARKED
WRITE ?68,"PARKED"
+2 if $GET(PAR)
QUIT
IF $PIECE($GET(^PSRX(RXN,"IB")),"^")
WRITE ?77,"Y"
SET CP=CP+1
+3 IF $GET(PSX(NODE))]""
WRITE ?85,"Y",?95,$SELECT(PSX(NODE)=0:"Transmitted",PSX(NODE)=1:"Dispensed",PSX(NODE)=2:"Retransmitted",PSX(NODE)=3:"Not Dispensed",1:"Unknown")
+4 QUIT
+5 ;
HD WRITE @IOF,?$SELECT('DUD:17,1:20),$SELECT('DUD:"Release/",1:"")_"Unreleased Report for "_$PIECE(^PS(59,SITE,0),"^",1),!
+1 IF $GET(DUD1)="N"
WRITE ?13,"Non-controlled Substance Prescriptions Only"
+2 IF $GET(DUD1)="C"
WRITE ?8,"Controlled Substance Prescriptions (",$SELECT(SCH=1:"Schedules I - II",SCH=2:"Schedules III - V",SCH=3:"Schedules I - V",1:"")_")"
+3 WRITE !?18,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!!,?47,"Fill/",?54,"Date",!,"Rx #",?16,"Drug",?47,"Ref#",?54,"Rel",?62,"Sch",?67,"Status",?75,"Copay "
if $GET(PSXSYS)
WRITE "CMOP CMOP Status"
WRITE !
FOR LIN=1:1:$SELECT($GET(PSXSYS):115,1:80)
WRITE "-"
+4 WRITE !
SET PG=PG+1
QUIT
+5 ;
TEST ;
+1 SET (PSOLCMF,PSOLCMR)=0
+2 FOR PSOLCR=0:0
SET PSOLCR=$ORDER(^PSRX(RXN,1,PSOLCR))
if 'PSOLCR
QUIT
IF $DATA(^(PSOLCR,0))
SET PSOLCMR=PSOLCR
+3 IF '$GET(PSOLCMR)
GOTO TESTX
+4 FOR PSOLCR=0:0
SET PSOLCR=$ORDER(^PSRX(RXN,"A",PSOLCR))
if 'PSOLCR!($GET(PSOLCMF))
QUIT
Begin DoDot:1
+5 if $PIECE($GET(^PSRX(RXN,"A",PSOLCR,0)),"^",2)'="I"
QUIT
+6 IF $GET(PSOLCMR)<6
if $PIECE($GET(^PSRX(RXN,"A",PSOLCR,0)),"^",4)=$GET(PSOLCMR)
SET PSOLCMF=1
QUIT
+7 SET PSOLCMRZ=$GET(PSOLCMR)+1
if PSOLCMRZ=$PIECE($GET(^PSRX(RXN,"A",PSOLCR,0)),"^",4)
SET PSOLCMF=1
KILL PSOLCMRZ
QUIT
End DoDot:1
TESTX KILL PSOLCR,PSOLCMR
+1 QUIT
CSDEA(X) ;CS Criteria .. returns a 1 if both DEA on drug & criteria 'N/C/B' are satisfied
+1 NEW DEA,DRUGDA
+2 SET DRUGDA=$$GET1^DIQ(52,X,6,"I")
SET DEA=$$GET1^DIQ(50,DRUGDA,3)
+3 ;both CS & non CS (all)
IF DUD1="B"
QUIT 1_"^"_+DEA
+4 ;CS
+5 IF DUD1="C"
QUIT $SELECT('+DEA:0,'$DATA(SCH(+DEA)):0,1:1_"^"_+DEA)
+6 ;Non CS
+7 IF (+DEA<1)!(+DEA>5)
QUIT 1_"^"_+DEA
+8 QUIT 0
+9 ;
SCH(X) ;Schedule conversion
+1 if +X<1
QUIT ""
+2 QUIT $PIECE("I^II^III^IV^V","^",X)
