PSOCPF1 ;BIR/BAA - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
;;7.0;OUTPATIENT PHARMACY;**463,572,592,636**;DEC 1997;Build 14
;
SORT ; get the data
H 5 ;592 - Allow IB background job to finish
K ^TMP($J,"PSOCPF"),^TMP($J,"PSOCPFX"),^TMP($J,"PSOCPFE")
; compile data to display here
N BDATE,EDATE,RXS,PAT,FILDT,END,RIEN,RSX,RFL,DFN,VADM,VAEL
S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
S RXS=$P(FILTERS(0),U,3),DFN=$P(FILTERS(0),U,4)
;read only selected patients RX's
F RX=0:0 S RX=$O(^PS(55,DFN,"P",RX)) Q:'RX D
. S RIEN=$P($G(^PS(55,DFN,"P",RX,0)),U)
. Q:'RIEN Q:'$D(^PSRX(RIEN,0))
. I RXS,'$D(FILTERS(1,RIEN)) Q
. I '$D(^PSRX(RIEN,0)) Q
. ; Get this RX's 0 fill and refills for fill date info
. ;PSO 636 Do not QUIT when 0 fill is out of date range
. ;I $D(^PSRX(RIEN,2)) S FILDT=$P(^PSRX(RIEN,2),U,2) Q:(FILDT<BDATE)!(FILDT>EDATE) D SORTRF ;0 fill
. I $D(^PSRX(RIEN,2)) S FILDT=$P(^PSRX(RIEN,2),U,2),RFL=0 I (FILDT'<BDATE)&(FILDT'>EDATE) D SORTRF ;0 fill
. F RFL=0:0 S RFL=$O(^PSRX(RIEN,1,RFL)) Q:'RFL D
.. S FILDT=$P(^PSRX(RIEN,1,RFL,0),U) Q:(FILDT<BDATE)!(FILDT>EDATE) D SORTRF ;x refills
Q
;
SORTRF ;Set fill number and call getdata
;PSO 636 Use fill# from global not AD index
;S RFL=$O(^PSRX("AD",FILDT,RIEN,"")) Q:'$D(^DPT(DFN,0)) D GETDATA(RIEN)
Q:'$D(^DPT(DFN,0))
D GETDATA(RIEN)
Q
;
GETDATA(RIEN) ;SET UP DATA FOR LIST MANAGER
;pso*7*636 remove SC,SCP,MTS,MTSO,CPY
N PTNM,PID,MED,RX,IBST1,RNB,MIEN,DEBTOR
N DRG,BLNO,ARST,ARST1,ARTRN,X,MREC,IBN,IBND,PBIL
N PRIEN,PIBN,PCOPAY
S RX=$$GET1^DIQ(52,RIEN_",",.01,"E")
S DRG=$$GET1^DIQ(52,RIEN_",",6,"I"),MED=$$GET1^DIQ(52,RIEN_",",6,"O")
I DRG="" Q
D DEM^VADPT S PTNM=VADM(1),PID=$P(VADM(2),U,1),PID=$E(PTNM,1)_$E(PID,6,9)
;PSO*7*636 remove SC,SCP,MTS,MTSD
;D ELIG^VADPT S MTS=$P(VAEL(9),U,2),SC=$P(VAEL(3),U,1),SCP=$P(VAEL(3),U,2),MTS=$P(VAEL(9),U,2)
;S MTSD=$$GET1^DIQ(2,DFN_",",999.2,"I")
;S X=$$RXST^IBARXEU(DFN,DT),CPY=$P(X,U,2)
I RFL S IBN=$$GET1^DIQ(52.1,RFL_","_RIEN,9,"I")
I 'RFL S IBN=$$GET1^DIQ(52,RIEN_",",106,"I")
;PSO*7*636 Select all RXs even when no billing number
;I IBN="" S (PBIL,BLNO,ARTRN,PRIEN,ARST1,ARST,DEBTOR)="" Q
S (PBIL,ARST1,ARST,BLNO,ARTRN,PBIL,PRIEN,PIBN,DEBTOR)=""
S BLNO=$$GET1^DIQ(350,IBN_",",.11,"I")
S ARTRN=$$GET1^DIQ(350,IBN_",",.12,"I")
; if no AR TRANSACTION NUMBER look for PARENT CHARGE
I ARTRN="" S PIBN=$$GET1^DIQ(350,IBN_",",.09,"I")
; PARENT CHARGE IBN doesn't match IBN
I PIBN'="",PIBN'=IBN D
. S ARTRN=$$GET1^DIQ(350,PIBN_",",.12,"I")
. ;PSO*7*636 remove CHARGE
. S ARST=$$GET1^DIQ(350,PIBN_",",.05,"I"),ARST1=$$GET1^DIQ(350,PIBN_",",.05,"O")
; if a AR TRANSACTION NUMBER exists set BILL NUMBER from AR TRANSACTION to PBIL,PRIEN
I ARTRN'="" S (PBIL,PRIEN)=$$GET1^DIQ(433,ARTRN_",",.03,"I")
; PARENT CHARGE IBN matches IBN
I PIBN'="",PIBN=IBN D
. ;get status from parent INTEGRATED BILLING ACTION
. S ARST=$$GET1^DIQ(350,PIBN_",",.05,"I"),ARST1=$$GET1^DIQ(350,PIBN_",",.05,"O")
; If no BILNO and theres a AR TRANSACTION BILL NUMBER, set BLNO & DEBTOR from ACCOUNTS RECEIVABLE
I BLNO="",PBIL'="" S BLNO=$$GET1^DIQ(430,PBIL_",",.01),DEBTOR=$$GET1^DIQ(430,PBIL_",",9,"I")
;PSO*7*636 DO NOT GET STATUS FROM ACCOUNTS RECEIVABLE
;I PRIEN'="",PIBN="" S ARST1=$$GET1^DIQ(430,PRIEN_",",8,"O"),ARST=$$GET1^DIQ(430,PRIEN_",",8,"I"),DEBTOR=$$GET1^DIQ(430,PRIEN_",",9,"I")
I PRIEN'="",PIBN="",DEBTOR="" S DEBTOR=$$GET1^DIQ(430,PRIEN_",",9,"I")
;PSO*7*636 Set Status (ARST1) to NOBILL if no status was found
;I ARST="" S ARST=$$GET1^DIQ(350.21,IBN_",",.01,"I"),ARST1=$$GET1^DIQ(350.21,IBN_",",.01,"O")
;GET STATUS FROM 350 NOT 350.21
I ARST="" S ARST=$$GET1^DIQ(350,IBN_",",.05,"I"),ARST1=$$GET1^DIQ(350,IBN_",",.05,"O")
I BLNO="" S ARST1="NOBILL#"
S PCOPAY=+$G(^PSRX(RIEN,"IB"))
;PSO*7*636 Remove SC,SCP,MTSD,MTS,CPY Add PCOPAY
S ^TMP($J,"PSOCPF",PTNM,RIEN,RFL)=PTNM_U_PID_U_MED_U_RIEN_U_RFL_U_ARTRN_U_RX_U_FILDT_U_BLNO_U_ARST1_U_PCOPAY_U_U_U_U_DFN_U_PBIL_U_ARST_U_PRIEN_U_IBN_U_U_DEBTOR
Q
;
CANCEL ; CANCEL COPAY STATUS
;
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,NAME,GOTPAT,RC,IBFR,IBTO
S CNT=0
D EN^VALM2($G(XQORNOD(0)))
;pso 636 Clear screen so all options work same
D CLEAR^VALM1
I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
. S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
.. S RC=$G(^TMP($J,"PSOCPFX",IBXX)),CNT=CNT+1
.. S NAME=$P(RC,U,1),PSODA=$P(RC,U,4),MED=$P(RC,U,3),RX=$P(RC,U,8),RFL=$P(RC,U,7)
.. I '$D(PSOPAR) D ^PSOLSET
.. W !!,?17,"PATIENT: ",NAME
.. W !,?17,"Medication: ",MED
.. W !,?17,"RX: ",RX_"-"_RFL
.. D ICN^PSODPT($P(^PSRX(PSODA,0),"^",2))
.. S PSORXN=$P(^PSRX(PSODA,0),"^"),PREA="R"
.. S PCOPAY=$G(^PSRX(PSODA,"IB"))
.. ;PSO 636 Display msg and 'return to continue'
.. I '$D(^PSRX(PSODA,"IB")) D Q
... W !!,"Rx # ",$P($G(^PSRX(PSODA,0)),"^")," has no charge data...NO action taken."
... D PAUSE^VALM1
.. I $P($G(^PSRX(PSODA,"PFS")),"^",2)="",$P(^PSRX(PSODA,"IB"),"^",2)'>0,$P(^PSRX(PSODA,"IB"),"^",4)'>0 D Q
... W !!,"Rx # ",$P($G(^PSRX(PSODA,0)),"^")," has no charge data...NO action taken."
... D PAUSE^VALM1
.. D ASKCAN
D SORT ;592 - Reload data after update
D BLD^PSOCPF
S VALMBCK="R"
Q
;
RESET ; RESET/CANCEL COPAY STATUS
;
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,NAME,GOTPAT,RC,IBFR,IBTO
S CNT=0
D EN^VALM2($G(XQORNOD(0)))
;pso 636 Clear screen so all options work same
D CLEAR^VALM1
I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
. S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
.. S RC=$G(^TMP($J,"PSOCPFX",IBXX)),CNT=CNT+1
.. S NAME=$P(RC,U,1),PSODA=$P(RC,U,4),MED=$P(RC,U,3),RX=$P(RC,U,8),RFL=$P(RC,U,7)
.. D STATUS(PSODA,RFL)
D SORT ;592 - Reload data after update
D BLD^PSOCPF
S VALMBCK="R"
Q
;
STATUS(PSODA,RFL) ; PROCESS STATUS CHANGE
N PSOIBQ,PREA,PSI,PSOCOMM,FLAG,PSOSUMM,PSONW,PSOINDPT,PSONEW,PSOOLD
S PSOSUMM=""
I '$D(PSOPAR) D ^PSOLSET
W !!,?17,"PATIENT: ",NAME
W !,?17,"Medication: ",MED
W !,?17,"RX: ",RX_"-"_RFL
;
D ICN^PSODPT($P(^PSRX(PSODA,0),"^",2))
S PSORXN=$P(^PSRX(PSODA,0),"^"),PREA="R"
S PCOPAY=$G(^PSRX(PSODA,"IB"))
W !!,"Rx # ",PSORXN," is a ",$S(+PCOPAY:"Copay",1:"No Copay")," prescription"
S PSOLFIL=$$LF^PSOPFSU1(PSODA) D PFSA^PSOPFSU1(PSODA,PSOLFIL,3) ;PSOCPC def PSOPFSA=1 if OP SC/EI's change.
D EXEMCHK^PSOCPC ; CHECK/CHANGE EXEMPTION FLAGS
S PSOIBQ=$G(^PSRX(PSODA,"IBQ"))
;
I '$G(^PSRX(PSODA,"IB")),PSOIBQ'["1" D G ASKCAN
. K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to reset the status to COPAY" D ^DIR K DIR
. I Y'=1 Q
. S DIC="^IBE(350.3,",DIC("S")="I $P(^(0),U,3)'=2",DIC(0)="AEQMZ",DIC("A")="Select Reason for Reset : " D ^DIC K DIC I Y'<0 S PSORSN=+Y
. S PREA="R",PSOOLD="No Copay",PSONW="Copay",PSOCOMM="" D ACTLOG^PSOCPA
. S PSI=0,PSOCOMM="Copay status of this Rx has been reset to COPAY." D SETSUMM^PSOCPC
. S $P(^PSRX(PSODA,"IB"),"^")=1 ;Reset flag to COPAY
;
I $G(^PSRX(PSODA,"IB")) D G ASKCAN
. K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to reset the status to NO COPAYMENT" D ^DIR K DIR
. I Y'=1 Q
. S DIC="^IBE(350.3,",DIC("S")="I $P(^(0),U,3)'=2",DIC(0)="AEQMZ",DIC("A")="Select Reason for Reset : " D ^DIC K DIC I Y'<0 S PSORSN=+Y
. S PREA="R",PSOOLD="Copay",PSONW="No Copay",PSOCOMM="" D ACTLOG^PSOCPA
. S PSI=0,PSOCOMM="Copay status of this Rx has been reset to NO COPAY." D SETSUMM^PSOCPC
. S $P(^PSRX(PSODA,"IB"),"^")="" ;Reset flag to NO COPAY
ASKCAN D ASKCAN^PSOCPD
;I $$FLAG(.PSOSUMM) S ^TMP($J,"PSOCPFC",NAME,PSODA,RFL)="Cancelled" ;592 - Removed this logic, all data is reloaded
D PRTSUMM^PSOCPB
RESETE K PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOMM,PSI
Q
;
EXPORT ; -- print excel spreadsheet.
I '$D(^TMP($J,"PSOCPF")) D BLD^PSOCPF S VALMBCK="R" Q
D CLEAR^VALM1,FULL^VALM1
S LCNT=0
D ^%ZISC
D DEVICE("EF")
;
D BLD^PSOCPF
D PAUSE^VALM1
S VALMBCK="R"
Q
;
EXCEL(FILTERS) ; print the data in excel format
;NAME_U_PID_U_MED_U_RX_"-"_RFL_U_$$FMTE^XLFDT(FILDT,"2DZ")_U_BLN_U_ARST1_U_SCO_U_SCP_U_U_U
U IO
N LCNT,PCE,REC,OUT,NAME,XX,BCNT,CNT,NXT,ZZ,ZZ1,ZZ2,OUT
N BDATE,EDATE,RIEN,RFL
S BDATE=$$FMTE^XLFDT($P(FILTERS,U,1),"2DZ")
S EDATE=$$FMTE^XLFDT($P(FILTERS,U,2),"2DZ")
D EXHDR
S LCNT=0,NAME=""
F S NAME=$O(^TMP($J,"PSOCPFE",NAME)) Q:NAME="" D
. S RIEN=0
. F S RIEN=$O(^TMP($J,"PSOCPFE",NAME,RIEN)) Q:RIEN="" D
.. S RFL=""
.. F S RFL=$O(^TMP($J,"PSOCPFE",NAME,RIEN,RFL)) Q:RFL="" D
... S REC=^TMP($J,"PSOCPFE",NAME,RIEN,RFL)
... W !,REC
W !,"END OF REPORT"
Q
;
DEVICE(TYPE) ; Ask user to select device
;
D CLEAR^VALM1
D FULL^VALM1
N %ZIS,CRT,MAXCNT,POP,IOST,MAXCNT,IOSL,ZTREQ
W !,"NO QUEUING ALLOWED FOR THIS REPORT"
W !,"This report must have a line length of at least 256.",!
S %ZIS="M" D ^%ZIS G:POP ENQ
; print report
I IOST["C-" S MAXCNT=IOSL-3,CRT=1
E S MAXCNT=IOSL,CRT=0
;
I TYPE="EF" U IO D EXCEL(FILTERS(0))
;
D ^%ZISC
;
I $D(ZTQUEUED) S ZTREQ="@"
;
ENQ Q
;
EXHDR ; -- excel header
N HDR
;^TMP($J,"PSOCPF",PTNM,RIEN,RFL)=PTNM_U_PID_U_MED_U_RIEN_U_RFL_U_RX_U_FILDT_U_BLNO_U_IBST1_U_SC_U_SCP_U_MTSD_U_MTS_U_DFN_U_IBST
W !,"Reset/Cancel Report"
W !,"From ",BDATE," TO ",EDATE
;PSO*7*636 remove SC,SCP
S HDR="Patient Name"_U_"ID"_U_"MEDICATION"_U_"RX"_U_"FILL DATE"_U_"BILL NO."_U_"STATUS"_U_U_U_U_U_"RX STATUS"
W !,HDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPF1 9401 printed Mar 13, 2025@21:30:47 Page 2
PSOCPF1 ;BIR/BAA - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
+1 ;;7.0;OUTPATIENT PHARMACY;**463,572,592,636**;DEC 1997;Build 14
+2 ;
SORT ; get the data
+1 ;592 - Allow IB background job to finish
HANG 5
+2 KILL ^TMP($JOB,"PSOCPF"),^TMP($JOB,"PSOCPFX"),^TMP($JOB,"PSOCPFE")
+3 ; compile data to display here
+4 NEW BDATE,EDATE,RXS,PAT,FILDT,END,RIEN,RSX,RFL,DFN,VADM,VAEL
+5 SET BDATE=$PIECE(FILTERS(0),U,1)
SET EDATE=$PIECE(FILTERS(0),U,2)
+6 SET RXS=$PIECE(FILTERS(0),U,3)
SET DFN=$PIECE(FILTERS(0),U,4)
+7 ;read only selected patients RX's
+8 FOR RX=0:0
SET RX=$ORDER(^PS(55,DFN,"P",RX))
if 'RX
QUIT
Begin DoDot:1
+9 SET RIEN=$PIECE($GET(^PS(55,DFN,"P",RX,0)),U)
+10 if 'RIEN
QUIT
if '$DATA(^PSRX(RIEN,0))
QUIT
+11 IF RXS
IF '$DATA(FILTERS(1,RIEN))
QUIT
+12 IF '$DATA(^PSRX(RIEN,0))
QUIT
+13 ; Get this RX's 0 fill and refills for fill date info
+14 ;PSO 636 Do not QUIT when 0 fill is out of date range
+15 ;I $D(^PSRX(RIEN,2)) S FILDT=$P(^PSRX(RIEN,2),U,2) Q:(FILDT<BDATE)!(FILDT>EDATE) D SORTRF ;0 fill
+16 ;0 fill
IF $DATA(^PSRX(RIEN,2))
SET FILDT=$PIECE(^PSRX(RIEN,2),U,2)
SET RFL=0
IF (FILDT'<BDATE)&(FILDT'>EDATE)
DO SORTRF
+17 FOR RFL=0:0
SET RFL=$ORDER(^PSRX(RIEN,1,RFL))
if 'RFL
QUIT
Begin DoDot:2
+18 ;x refills
SET FILDT=$PIECE(^PSRX(RIEN,1,RFL,0),U)
if (FILDT<BDATE)!(FILDT>EDATE)
QUIT
DO SORTRF
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
SORTRF ;Set fill number and call getdata
+1 ;PSO 636 Use fill# from global not AD index
+2 ;S RFL=$O(^PSRX("AD",FILDT,RIEN,"")) Q:'$D(^DPT(DFN,0)) D GETDATA(RIEN)
+3 if '$DATA(^DPT(DFN,0))
QUIT
+4 DO GETDATA(RIEN)
+5 QUIT
+6 ;
GETDATA(RIEN) ;SET UP DATA FOR LIST MANAGER
+1 ;pso*7*636 remove SC,SCP,MTS,MTSO,CPY
+2 NEW PTNM,PID,MED,RX,IBST1,RNB,MIEN,DEBTOR
+3 NEW DRG,BLNO,ARST,ARST1,ARTRN,X,MREC,IBN,IBND,PBIL
+4 NEW PRIEN,PIBN,PCOPAY
+5 SET RX=$$GET1^DIQ(52,RIEN_",",.01,"E")
+6 SET DRG=$$GET1^DIQ(52,RIEN_",",6,"I")
SET MED=$$GET1^DIQ(52,RIEN_",",6,"O")
+7 IF DRG=""
QUIT
+8 DO DEM^VADPT
SET PTNM=VADM(1)
SET PID=$PIECE(VADM(2),U,1)
SET PID=$EXTRACT(PTNM,1)_$EXTRACT(PID,6,9)
+9 ;PSO*7*636 remove SC,SCP,MTS,MTSD
+10 ;D ELIG^VADPT S MTS=$P(VAEL(9),U,2),SC=$P(VAEL(3),U,1),SCP=$P(VAEL(3),U,2),MTS=$P(VAEL(9),U,2)
+11 ;S MTSD=$$GET1^DIQ(2,DFN_",",999.2,"I")
+12 ;S X=$$RXST^IBARXEU(DFN,DT),CPY=$P(X,U,2)
+13 IF RFL
SET IBN=$$GET1^DIQ(52.1,RFL_","_RIEN,9,"I")
+14 IF 'RFL
SET IBN=$$GET1^DIQ(52,RIEN_",",106,"I")
+15 ;PSO*7*636 Select all RXs even when no billing number
+16 ;I IBN="" S (PBIL,BLNO,ARTRN,PRIEN,ARST1,ARST,DEBTOR)="" Q
+17 SET (PBIL,ARST1,ARST,BLNO,ARTRN,PBIL,PRIEN,PIBN,DEBTOR)=""
+18 SET BLNO=$$GET1^DIQ(350,IBN_",",.11,"I")
+19 SET ARTRN=$$GET1^DIQ(350,IBN_",",.12,"I")
+20 ; if no AR TRANSACTION NUMBER look for PARENT CHARGE
+21 IF ARTRN=""
SET PIBN=$$GET1^DIQ(350,IBN_",",.09,"I")
+22 ; PARENT CHARGE IBN doesn't match IBN
+23 IF PIBN'=""
IF PIBN'=IBN
Begin DoDot:1
+24 SET ARTRN=$$GET1^DIQ(350,PIBN_",",.12,"I")
+25 ;PSO*7*636 remove CHARGE
+26 SET ARST=$$GET1^DIQ(350,PIBN_",",.05,"I")
SET ARST1=$$GET1^DIQ(350,PIBN_",",.05,"O")
End DoDot:1
+27 ; if a AR TRANSACTION NUMBER exists set BILL NUMBER from AR TRANSACTION to PBIL,PRIEN
+28 IF ARTRN'=""
SET (PBIL,PRIEN)=$$GET1^DIQ(433,ARTRN_",",.03,"I")
+29 ; PARENT CHARGE IBN matches IBN
+30 IF PIBN'=""
IF PIBN=IBN
Begin DoDot:1
+31 ;get status from parent INTEGRATED BILLING ACTION
+32 SET ARST=$$GET1^DIQ(350,PIBN_",",.05,"I")
SET ARST1=$$GET1^DIQ(350,PIBN_",",.05,"O")
End DoDot:1
+33 ; If no BILNO and theres a AR TRANSACTION BILL NUMBER, set BLNO & DEBTOR from ACCOUNTS RECEIVABLE
+34 IF BLNO=""
IF PBIL'=""
SET BLNO=$$GET1^DIQ(430,PBIL_",",.01)
SET DEBTOR=$$GET1^DIQ(430,PBIL_",",9,"I")
+35 ;PSO*7*636 DO NOT GET STATUS FROM ACCOUNTS RECEIVABLE
+36 ;I PRIEN'="",PIBN="" S ARST1=$$GET1^DIQ(430,PRIEN_",",8,"O"),ARST=$$GET1^DIQ(430,PRIEN_",",8,"I"),DEBTOR=$$GET1^DIQ(430,PRIEN_",",9,"I")
+37 IF PRIEN'=""
IF PIBN=""
IF DEBTOR=""
SET DEBTOR=$$GET1^DIQ(430,PRIEN_",",9,"I")
+38 ;PSO*7*636 Set Status (ARST1) to NOBILL if no status was found
+39 ;I ARST="" S ARST=$$GET1^DIQ(350.21,IBN_",",.01,"I"),ARST1=$$GET1^DIQ(350.21,IBN_",",.01,"O")
+40 ;GET STATUS FROM 350 NOT 350.21
+41 IF ARST=""
SET ARST=$$GET1^DIQ(350,IBN_",",.05,"I")
SET ARST1=$$GET1^DIQ(350,IBN_",",.05,"O")
+42 IF BLNO=""
SET ARST1="NOBILL#"
+43 SET PCOPAY=+$GET(^PSRX(RIEN,"IB"))
+44 ;PSO*7*636 Remove SC,SCP,MTSD,MTS,CPY Add PCOPAY
+45 SET ^TMP($JOB,"PSOCPF",PTNM,RIEN,RFL)=PTNM_U_PID_U_MED_U_RIEN_U_RFL_U_ARTRN_U_RX_U_FILDT_U_BLNO_U_ARST1_U_PCOPAY_U_U_U_U_DFN_U_PBIL_U_ARST_U_PRIEN_U_IBN_U_U_DEBTOR
+46 QUIT
+47 ;
CANCEL ; CANCEL COPAY STATUS
+1 ;
+2 DO FULL^VALM1
+3 NEW I,J,IBXX,VALMY,ECNT,NAME,GOTPAT,RC,IBFR,IBTO
+4 SET CNT=0
+5 DO EN^VALM2($GET(XQORNOD(0)))
+6 ;pso 636 Clear screen so all options work same
+7 DO CLEAR^VALM1
+8 IF $DATA(VALMY)
IF $DATA(^TMP($JOB,"PSOCPF"))
Begin DoDot:1
+9 SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:2
+10 SET RC=$GET(^TMP($JOB,"PSOCPFX",IBXX))
SET CNT=CNT+1
+11 SET NAME=$PIECE(RC,U,1)
SET PSODA=$PIECE(RC,U,4)
SET MED=$PIECE(RC,U,3)
SET RX=$PIECE(RC,U,8)
SET RFL=$PIECE(RC,U,7)
+12 IF '$DATA(PSOPAR)
DO ^PSOLSET
+13 WRITE !!,?17,"PATIENT: ",NAME
+14 WRITE !,?17,"Medication: ",MED
+15 WRITE !,?17,"RX: ",RX_"-"_RFL
+16 DO ICN^PSODPT($PIECE(^PSRX(PSODA,0),"^",2))
+17 SET PSORXN=$PIECE(^PSRX(PSODA,0),"^")
SET PREA="R"
+18 SET PCOPAY=$GET(^PSRX(PSODA,"IB"))
+19 ;PSO 636 Display msg and 'return to continue'
+20 IF '$DATA(^PSRX(PSODA,"IB"))
Begin DoDot:3
+21 WRITE !!,"Rx # ",$PIECE($GET(^PSRX(PSODA,0)),"^")," has no charge data...NO action taken."
+22 DO PAUSE^VALM1
End DoDot:3
QUIT
+23 IF $PIECE($GET(^PSRX(PSODA,"PFS")),"^",2)=""
IF $PIECE(^PSRX(PSODA,"IB"),"^",2)'>0
IF $PIECE(^PSRX(PSODA,"IB"),"^",4)'>0
Begin DoDot:3
+24 WRITE !!,"Rx # ",$PIECE($GET(^PSRX(PSODA,0)),"^")," has no charge data...NO action taken."
+25 DO PAUSE^VALM1
End DoDot:3
QUIT
+26 DO ASKCAN
End DoDot:2
End DoDot:1
+27 ;592 - Reload data after update
DO SORT
+28 DO BLD^PSOCPF
+29 SET VALMBCK="R"
+30 QUIT
+31 ;
RESET ; RESET/CANCEL COPAY STATUS
+1 ;
+2 DO FULL^VALM1
+3 NEW I,J,IBXX,VALMY,ECNT,NAME,GOTPAT,RC,IBFR,IBTO
+4 SET CNT=0
+5 DO EN^VALM2($GET(XQORNOD(0)))
+6 ;pso 636 Clear screen so all options work same
+7 DO CLEAR^VALM1
+8 IF $DATA(VALMY)
IF $DATA(^TMP($JOB,"PSOCPF"))
Begin DoDot:1
+9 SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:2
+10 SET RC=$GET(^TMP($JOB,"PSOCPFX",IBXX))
SET CNT=CNT+1
+11 SET NAME=$PIECE(RC,U,1)
SET PSODA=$PIECE(RC,U,4)
SET MED=$PIECE(RC,U,3)
SET RX=$PIECE(RC,U,8)
SET RFL=$PIECE(RC,U,7)
+12 DO STATUS(PSODA,RFL)
End DoDot:2
End DoDot:1
+13 ;592 - Reload data after update
DO SORT
+14 DO BLD^PSOCPF
+15 SET VALMBCK="R"
+16 QUIT
+17 ;
STATUS(PSODA,RFL) ; PROCESS STATUS CHANGE
+1 NEW PSOIBQ,PREA,PSI,PSOCOMM,FLAG,PSOSUMM,PSONW,PSOINDPT,PSONEW,PSOOLD
+2 SET PSOSUMM=""
+3 IF '$DATA(PSOPAR)
DO ^PSOLSET
+4 WRITE !!,?17,"PATIENT: ",NAME
+5 WRITE !,?17,"Medication: ",MED
+6 WRITE !,?17,"RX: ",RX_"-"_RFL
+7 ;
+8 DO ICN^PSODPT($PIECE(^PSRX(PSODA,0),"^",2))
+9 SET PSORXN=$PIECE(^PSRX(PSODA,0),"^")
SET PREA="R"
+10 SET PCOPAY=$GET(^PSRX(PSODA,"IB"))
+11 WRITE !!,"Rx # ",PSORXN," is a ",$SELECT(+PCOPAY:"Copay",1:"No Copay")," prescription"
+12 ;PSOCPC def PSOPFSA=1 if OP SC/EI's change.
SET PSOLFIL=$$LF^PSOPFSU1(PSODA)
DO PFSA^PSOPFSU1(PSODA,PSOLFIL,3)
+13 ; CHECK/CHANGE EXEMPTION FLAGS
DO EXEMCHK^PSOCPC
+14 SET PSOIBQ=$GET(^PSRX(PSODA,"IBQ"))
+15 ;
+16 IF '$GET(^PSRX(PSODA,"IB"))
IF PSOIBQ'["1"
Begin DoDot:1
+17 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Do you want to reset the status to COPAY"
DO ^DIR
KILL DIR
+18 IF Y'=1
QUIT
+19 SET DIC="^IBE(350.3,"
SET DIC("S")="I $P(^(0),U,3)'=2"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Reason for Reset : "
DO ^DIC
KILL DIC
IF Y'<0
SET PSORSN=+Y
+20 SET PREA="R"
SET PSOOLD="No Copay"
SET PSONW="Copay"
SET PSOCOMM=""
DO ACTLOG^PSOCPA
+21 SET PSI=0
SET PSOCOMM="Copay status of this Rx has been reset to COPAY."
DO SETSUMM^PSOCPC
+22 ;Reset flag to COPAY
SET $PIECE(^PSRX(PSODA,"IB"),"^")=1
End DoDot:1
GOTO ASKCAN
+23 ;
+24 IF $GET(^PSRX(PSODA,"IB"))
Begin DoDot:1
+25 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Do you want to reset the status to NO COPAYMENT"
DO ^DIR
KILL DIR
+26 IF Y'=1
QUIT
+27 SET DIC="^IBE(350.3,"
SET DIC("S")="I $P(^(0),U,3)'=2"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Reason for Reset : "
DO ^DIC
KILL DIC
IF Y'<0
SET PSORSN=+Y
+28 SET PREA="R"
SET PSOOLD="Copay"
SET PSONW="No Copay"
SET PSOCOMM=""
DO ACTLOG^PSOCPA
+29 SET PSI=0
SET PSOCOMM="Copay status of this Rx has been reset to NO COPAY."
DO SETSUMM^PSOCPC
+30 ;Reset flag to NO COPAY
SET $PIECE(^PSRX(PSODA,"IB"),"^")=""
End DoDot:1
GOTO ASKCAN
ASKCAN DO ASKCAN^PSOCPD
+1 ;I $$FLAG(.PSOSUMM) S ^TMP($J,"PSOCPFC",NAME,PSODA,RFL)="Cancelled" ;592 - Removed this logic, all data is reloaded
+2 DO PRTSUMM^PSOCPB
RESETE KILL PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOMM,PSI
+1 QUIT
+2 ;
EXPORT ; -- print excel spreadsheet.
+1 IF '$DATA(^TMP($JOB,"PSOCPF"))
DO BLD^PSOCPF
SET VALMBCK="R"
QUIT
+2 DO CLEAR^VALM1
DO FULL^VALM1
+3 SET LCNT=0
+4 DO ^%ZISC
+5 DO DEVICE("EF")
+6 ;
+7 DO BLD^PSOCPF
+8 DO PAUSE^VALM1
+9 SET VALMBCK="R"
+10 QUIT
+11 ;
EXCEL(FILTERS) ; print the data in excel format
+1 ;NAME_U_PID_U_MED_U_RX_"-"_RFL_U_$$FMTE^XLFDT(FILDT,"2DZ")_U_BLN_U_ARST1_U_SCO_U_SCP_U_U_U
+2 USE IO
+3 NEW LCNT,PCE,REC,OUT,NAME,XX,BCNT,CNT,NXT,ZZ,ZZ1,ZZ2,OUT
+4 NEW BDATE,EDATE,RIEN,RFL
+5 SET BDATE=$$FMTE^XLFDT($PIECE(FILTERS,U,1),"2DZ")
+6 SET EDATE=$$FMTE^XLFDT($PIECE(FILTERS,U,2),"2DZ")
+7 DO EXHDR
+8 SET LCNT=0
SET NAME=""
+9 FOR
SET NAME=$ORDER(^TMP($JOB,"PSOCPFE",NAME))
if NAME=""
QUIT
Begin DoDot:1
+10 SET RIEN=0
+11 FOR
SET RIEN=$ORDER(^TMP($JOB,"PSOCPFE",NAME,RIEN))
if RIEN=""
QUIT
Begin DoDot:2
+12 SET RFL=""
+13 FOR
SET RFL=$ORDER(^TMP($JOB,"PSOCPFE",NAME,RIEN,RFL))
if RFL=""
QUIT
Begin DoDot:3
+14 SET REC=^TMP($JOB,"PSOCPFE",NAME,RIEN,RFL)
+15 WRITE !,REC
End DoDot:3
End DoDot:2
End DoDot:1
+16 WRITE !,"END OF REPORT"
+17 QUIT
+18 ;
DEVICE(TYPE) ; Ask user to select device
+1 ;
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 NEW %ZIS,CRT,MAXCNT,POP,IOST,MAXCNT,IOSL,ZTREQ
+5 WRITE !,"NO QUEUING ALLOWED FOR THIS REPORT"
+6 WRITE !,"This report must have a line length of at least 256.",!
+7 SET %ZIS="M"
DO ^%ZIS
if POP
GOTO ENQ
+8 ; print report
+9 IF IOST["C-"
SET MAXCNT=IOSL-3
SET CRT=1
+10 IF '$TEST
SET MAXCNT=IOSL
SET CRT=0
+11 ;
+12 IF TYPE="EF"
USE IO
DO EXCEL(FILTERS(0))
+13 ;
+14 DO ^%ZISC
+15 ;
+16 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+17 ;
ENQ QUIT
+1 ;
EXHDR ; -- excel header
+1 NEW HDR
+2 ;^TMP($J,"PSOCPF",PTNM,RIEN,RFL)=PTNM_U_PID_U_MED_U_RIEN_U_RFL_U_RX_U_FILDT_U_BLNO_U_IBST1_U_SC_U_SCP_U_MTSD_U_MTS_U_DFN_U_IBST
+3 WRITE !,"Reset/Cancel Report"
+4 WRITE !,"From ",BDATE," TO ",EDATE
+5 ;PSO*7*636 remove SC,SCP
+6 SET HDR="Patient Name"_U_"ID"_U_"MEDICATION"_U_"RX"_U_"FILL DATE"_U_"BILL NO."_U_"STATUS"_U_U_U_U_U_"RX STATUS"
+7 WRITE !,HDR
+8 QUIT
