- PSODISP1 ;BHAM ISC/SAB,PDW - Rx released/unrelease report ;29-May-2012 14:45;PLS
- ;;7.0;OUTPATIENT PHARMACY;**15,9,33,1013,1015**;DEC 1997;Build 62
- ;External reference to ^PS(59.7 supported by DBIA 694
- ;External reference to ^PSDRUG( supported by DBIA 221
- ;Modified - IHS/MSC/MGH - 10/07/2011 - Added fields for patch 1013
- 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
- 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"
- .F G="BEGDT","ENDDT","PSDATE","PEDATE","SITE","DUD","DUD1","PSXSYS" S:$D(@G) ZTSAVE(G)=""
- .D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K ZTSK,IO("Q")
- ;
- BC S PG=1,(UNREL,CP)=0 U IO D HD,RPT
- W !!," # of Unreleased Fills - "_UNREL_" # of Copay Fills - "_CP
- I $E($G(IOST),1,2)'["C-" W !,@IOF
- EXIT D ^%ZISC K PG,LIN,G,UNREL,BEG,BEGDT,END,ENDDT,DR,X,X1,X2,Y,REC,DIR,DIRUT,DUOUT,I,Y,RXN,NODE,PAR,BDT,PSX,PSXZ
- 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
- I $$CSDEA(RXN)=0 Q ; quit if CS Criteria fails
- ;IHS/MSC/MGH - 10/07/2011
- ;I $P(^PSRX(RXN,2),"^",13) W !,$P(^PSRX(RXN,0),"^"),?16,"Original" S Y=$P(^PSRX(RXN,2),"^",13) X ^DD("DD") W ?29,$S(Y["@":$P(Y,"@"),1:Y),?50,"YES" D CP1 Q
- I $P(^PSRX(RXN,2),"^",13) D Q
- .W !,$P(^PSRX(RXN,0),"^"),?12,"Original"
- .S Y=$P(^PSRX(RXN,2),"^",2) X ^DD("DD") W ?25,$S(Y["@":$P(Y,"@"),1:Y) ;IHS/MSC/MGH added fill date
- .S Y=$P(^PSRX(RXN,2),"^",13) X ^DD("DD") W ?39,$S(Y["@":$P(Y,"@"),1:Y),?52,"YES" D CP1
- I '$P(^PSRX(RXN,2),"^",13) D Q:('$G(LBLP)&($G(PSX(0))']"")) W !,$P(^PSRX(RXN,0),"^"),?16,"Original",?50,"No" 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
- ;I $G(PSX(0))]"" W ?85,"YES",?95,$S(PSX(0)=0:"Transmitted",PSX(0)=1:"DISPENSED",PSX(0)=2:"Retransmitted",PSX(0)=3:"Not Dispensed",1:"Unknown")
- 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
- I $$CSDEA(RXN)=0 Q ; quit if CS Criteria fails
- I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",$S('$G(PAR):18,1:19)) D G CP1
- .W !,$P(^PSRX(RXN,0),"^"),?12,$S('$G(PAR):"Refill",1:"Partial")_" #",NODE
- .S Y=$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",1) X ^DD("DD") W ?25,$S(Y["@":$P(Y,"@"),1:Y) ;IHS/MSC/MGH added fill date
- .S Y=$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",$S('$G(PAR):18,1:19)) X ^DD("DD") W ?39,$S(Y["@":$P(Y,"@"),1:Y),?52,"Yes"
- I '$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",$S('$G(PAR):18,1:19)) D Q:('$G(LBLP)&($G(PSX(NODE))']"")) D TEST Q:'$G(LBLP)&($G(PSOLCMF)) W !,$P(^PSRX(RXN,0),"^"),?12,$S('$G(PAR):"Refill",1:"Partial")_" #",NODE,?52,"No" S UNREL=UNREL+1
- .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
- CP1 W ?60,$S(XY=1:"Non-verified",XY=2:"Refill",XY=3!(XY=16):"Hold",XY=5:"Suspended",XY=10:"Done",XY=11:"Expired",XY=12!(XY=14)!(XY=15):"Discontinued",1:"Active")
- ;IHS/MSC/MGH Patch 10103 Added call to add a second line of items for report
- I '$G(PAR) D
- .I $P($G(^PSRX(RXN,"IB")),"^") W ?75,"Yes" S CP=CP+1
- .I $G(PSX(NODE))]"" W ?85,"Yes",?95,$S(PSX(NODE)=0:"Transmitted",PSX(NODE)=1:"Dispensed",PSX(NODE)=2:"Retransmitted",PSX(NODE)=3:"Not Dispensed",1:"Unknown")
- D PTDATA1
- 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 ?17,"Controlled Substance Prescriptions Only"
- W !?18,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!!,?12,"Fill/",?25,"Date",?39,"Date"
- W !,"Rx #",?12,"Refill",?25,"Filled",?39,"Released",?52,"Released",?61,"Status",?74,"Copay " W:$G(PSXSYS) "CMOP CMOP Status"
- ;IHS/MSC/MGH added line to header patch 1013
- W !?2,"Pt Name",?23,"DOB",?36,"HRN",?46,"Pharmacist",?66,"Finisher"
- 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 Critera .. returns a 1 if both DEA on drug & criteria 'N/C/B' are satisfied
- I DUD1="B" Q 1 ;both CS & non CS (all)
- N DEA,DRUGDA
- S DRUGDA=$$GET1^DIQ(52,X,6,"I"),DEA=$$GET1^DIQ(50,DRUGDA,3)
- S DEA=$S(DEA="":0,DEA["C":1,DEA["A":1,1:0) ;***
- I DUD1="N",DEA=0 Q 1 ; no CS
- I DUD1="C",DEA=1 Q 1 ; CS only
- Q 0
- PTDATA1 ;Extra fields added to report Patch 1013
- N PT,NAME,DOB,HRCN,PHARM,FILL,IEN
- S (PHARM,FILL)=""
- S PT=$P($G(^PSRX(RXN,0)),U,2)
- Q:PT=""
- S NAME=$$GET1^DIQ(2,PT,.01)
- S DOB=$$GET1^DIQ(2,PT,.03)
- S HRCN=$$HRCN^TIUR2(PT,+$G(DUZ(2)))
- I +NODE D
- .S IEN=NODE_","_RXN_","
- .I '$G(PAR) D
- ..S PHARM=$$GET1^DIQ(52.1,IEN,4)
- .I $G(PAR) D
- ..S PHARM=$$GET1^DIQ(52.2,IEN,.05)
- E D
- .S PHARM=$$GET1^DIQ(52,RXN,23)
- .S FILL=$$GET1^DIQ(52,RXN,38)
- W !,?2,$E(NAME,1,19),?23,DOB,?36,HRCN,?46,$E(PHARM,1,19),?66,$E(FILL,U,14),!
- Q
- HRCN(PT,SITE) ;EP; IHS/MSC/MGH return chart number
- Q $P($G(^AUPNPAT(PT,41,SITE,0)),U,2)
- PSODISP1 ;BHAM ISC/SAB,PDW - Rx released/unrelease report ;29-May-2012 14:45;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**15,9,33,1013,1015**;DEC 1997;Build 62
- +2 ;External reference to ^PS(59.7 supported by DBIA 694
- +3 ;External reference to ^PSDRUG( supported by DBIA 221
- +4 ;Modified - IHS/MSC/MGH - 10/07/2011 - Added fields for patch 1013
- +5 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 WRITE !
- SET %DT(0)=PSIN
- SET X1=DT
- SET X2=-30
- DO C^%DTC
- IF X>PSIN
- SET (BEGDT,Y)=X
- +7 IF '$TEST
- SET (BEGDT,Y)=PSIN
- +8 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
- +9 SET Y=DT
- XECUTE ^DD("DD")
- SET END=Y
- +10 SET %DT("A")="Ending date: "
- SET %DT("B")=END
- DO ^%DT
- KILL %DT
- IF "^"[$EXTRACT(X)
- GOTO EXIT
- SET ENDDT=Y
- +11 SET Y=ENDDT
- DO DD^%DT
- SET PEDATE=Y
- SET Y=BEGDT
- DO DD^%DT
- SET PSDATE=Y
- +12 ; ***
- +13 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")=""
- +14 DO ^%ZIS
- IF POP
- SET IOP=PSOION
- DO ^%ZIS
- KILL IOP,PSOION
- GOTO EXIT
- +15 KILL PSOION
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +16 SET ZTRTN="BC^PSODISP1"
- SET ZTDESC="Report of released & unreleased prescriptions"
- +17 FOR G="BEGDT","ENDDT","PSDATE","PEDATE","SITE","DUD","DUD1","PSXSYS"
- IF $DATA(@G)
- SET ZTSAVE(G)=""
- +18 DO ^%ZTLOAD
- IF $DATA(ZTSK)
- WRITE !,"Report Queued to Print !!",!
- KILL ZTSK,IO("Q")
- End DoDot:1
- GOTO EXIT
- +19 ;
- BC SET PG=1
- SET (UNREL,CP)=0
- USE IO
- DO HD
- DO RPT
- +1 WRITE !!," # of Unreleased Fills - "_UNREL_" # of Copay Fills - "_CP
- +2 IF $EXTRACT($GET(IOST),1,2)'["C-"
- WRITE !,@IOF
- EXIT DO ^%ZISC
- KILL PG,LIN,G,UNREL,BEG,BEGDT,END,ENDDT,DR,X,X1,X2,Y,REC,DIR,DIRUT,DUOUT,I,Y,RXN,NODE,PAR,BDT,PSX,PSXZ
- +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
- IF $$CSDEA(RXN)=0
- QUIT
- +5 ;IHS/MSC/MGH - 10/07/2011
- +6 ;I $P(^PSRX(RXN,2),"^",13) W !,$P(^PSRX(RXN,0),"^"),?16,"Original" S Y=$P(^PSRX(RXN,2),"^",13) X ^DD("DD") W ?29,$S(Y["@":$P(Y,"@"),1:Y),?50,"YES" D CP1 Q
- +7 IF $PIECE(^PSRX(RXN,2),"^",13)
- Begin DoDot:1
- +8 WRITE !,$PIECE(^PSRX(RXN,0),"^"),?12,"Original"
- +9 ;IHS/MSC/MGH added fill date
- SET Y=$PIECE(^PSRX(RXN,2),"^",2)
- XECUTE ^DD("DD")
- WRITE ?25,$SELECT(Y["@":$PIECE(Y,"@"),1:Y)
- +10 SET Y=$PIECE(^PSRX(RXN,2),"^",13)
- XECUTE ^DD("DD")
- WRITE ?39,$SELECT(Y["@":$PIECE(Y,"@"),1:Y),?52,"YES"
- DO CP1
- End DoDot:1
- QUIT
- +11 IF '$PIECE(^PSRX(RXN,2),"^",13)
- Begin DoDot:1
- +12 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 !,$PIECE(^PSRX(RXN,0),"^"),?16,"Original",?50,"No"
- SET UNREL=UNREL+1
- DO CP1
- +13 ;I $G(PSX(0))]"" W ?85,"YES",?95,$S(PSX(0)=0:"Transmitted",PSX(0)=1:"DISPENSED",PSX(0)=2:"Retransmitted",PSX(0)=3:"Not Dispensed",1:"Unknown")
- +14 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
- IF $$CSDEA(RXN)=0
- QUIT
- +6 IF $PIECE($GET(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0)),"^",$SELECT('$GET(PAR):18,1:19))
- Begin DoDot:1
- +7 WRITE !,$PIECE(^PSRX(RXN,0),"^"),?12,$SELECT('$GET(PAR):"Refill",1:"Partial")_" #",NODE
- +8 ;IHS/MSC/MGH added fill date
- SET Y=$PIECE(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0),"^",1)
- XECUTE ^DD("DD")
- WRITE ?25,$SELECT(Y["@":$PIECE(Y,"@"),1:Y)
- +9 SET Y=$PIECE(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0),"^",$SELECT('$GET(PAR):18,1:19))
- XECUTE ^DD("DD")
- WRITE ?39,$SELECT(Y["@":$PIECE(Y,"@"),1:Y),?52,"Yes"
- End DoDot:1
- GOTO CP1
- +10 IF '$PIECE(^PSRX(RXN,$SELECT('$GET(PAR):1,1:"P"),NODE,0),"^",$SELECT('$GET(PAR):18,1:19))
- Begin DoDot:1
- +11 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
- End DoDot:1
- IF ('$GET(LBLP)&($GET(PSX(NODE))']""))
- QUIT
- DO TEST
- IF '$GET(LBLP)&($GET(PSOLCMF))
- QUIT
- WRITE !,$PIECE(^PSRX(RXN,0),"^"),?12,$SELECT('$GET(PAR):"Refill",1:"Partial")_" #",NODE,?52,"No"
- SET UNREL=UNREL+1
- CP1 WRITE ?60,$SELECT(XY=1:"Non-verified",XY=2:"Refill",XY=3!(XY=16):"Hold",XY=5:"Suspended",XY=10:"Done",XY=11:"Expired",XY=12!(XY=14)!(XY=15):"Discontinued",1:"Active")
- +1 ;IHS/MSC/MGH Patch 10103 Added call to add a second line of items for report
- +2 IF '$GET(PAR)
- Begin DoDot:1
- +3 IF $PIECE($GET(^PSRX(RXN,"IB")),"^")
- WRITE ?75,"Yes"
- SET CP=CP+1
- +4 IF $GET(PSX(NODE))]""
- WRITE ?85,"Yes",?95,$SELECT(PSX(NODE)=0:"Transmitted",PSX(NODE)=1:"Dispensed",PSX(NODE)=2:"Retransmitted",PSX(NODE)=3:"Not Dispensed",1:"Unknown")
- End DoDot:1
- +5 DO PTDATA1
- +6 QUIT
- +7 ;
- 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 ?17,"Controlled Substance Prescriptions Only"
- +3 WRITE !?18,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!!,?12,"Fill/",?25,"Date",?39,"Date"
- +4 WRITE !,"Rx #",?12,"Refill",?25,"Filled",?39,"Released",?52,"Released",?61,"Status",?74,"Copay "
- IF $GET(PSXSYS)
- WRITE "CMOP CMOP Status"
- +5 ;IHS/MSC/MGH added line to header patch 1013
- +6 WRITE !?2,"Pt Name",?23,"DOB",?36,"HRN",?46,"Pharmacist",?66,"Finisher"
- +7 WRITE !
- FOR LIN=1:1:$SELECT($GET(PSXSYS):115,1:80)
- WRITE "-"
- +8 WRITE !
- SET PG=PG+1
- QUIT
- +9 ;
- 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 Critera .. returns a 1 if both DEA on drug & criteria 'N/C/B' are satisfied
- +1 ;both CS & non CS (all)
- IF DUD1="B"
- QUIT 1
- +2 NEW DEA,DRUGDA
- +3 SET DRUGDA=$$GET1^DIQ(52,X,6,"I")
- SET DEA=$$GET1^DIQ(50,DRUGDA,3)
- +4 ;***
- SET DEA=$SELECT(DEA="":0,DEA["C":1,DEA["A":1,1:0)
- +5 ; no CS
- IF DUD1="N"
- IF DEA=0
- QUIT 1
- +6 ; CS only
- IF DUD1="C"
- IF DEA=1
- QUIT 1
- +7 QUIT 0
- PTDATA1 ;Extra fields added to report Patch 1013
- +1 NEW PT,NAME,DOB,HRCN,PHARM,FILL,IEN
- +2 SET (PHARM,FILL)=""
- +3 SET PT=$PIECE($GET(^PSRX(RXN,0)),U,2)
- +4 IF PT=""
- QUIT
- +5 SET NAME=$$GET1^DIQ(2,PT,.01)
- +6 SET DOB=$$GET1^DIQ(2,PT,.03)
- +7 SET HRCN=$$HRCN^TIUR2(PT,+$GET(DUZ(2)))
- +8 IF +NODE
- Begin DoDot:1
- +9 SET IEN=NODE_","_RXN_","
- +10 IF '$GET(PAR)
- Begin DoDot:2
- +11 SET PHARM=$$GET1^DIQ(52.1,IEN,4)
- End DoDot:2
- +12 IF $GET(PAR)
- Begin DoDot:2
- +13 SET PHARM=$$GET1^DIQ(52.2,IEN,.05)
- End DoDot:2
- End DoDot:1
- +14 IF '$TEST
- Begin DoDot:1
- +15 SET PHARM=$$GET1^DIQ(52,RXN,23)
- +16 SET FILL=$$GET1^DIQ(52,RXN,38)
- End DoDot:1
- +17 WRITE !,?2,$EXTRACT(NAME,1,19),?23,DOB,?36,HRCN,?46,$EXTRACT(PHARM,1,19),?66,$EXTRACT(FILL,U,14),!
- +18 QUIT
- HRCN(PT,SITE) ;EP; IHS/MSC/MGH return chart number
- +1 QUIT $PIECE($GET(^AUPNPAT(PT,41,SITE,0)),U,2)
