- 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 Feb 18, 2025@23:53:34 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)