Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOCPF1

PSOCPF1.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. SORT ; get the data
  1.  H 5  ;592 - Allow IB background job to finish
  1.  K ^TMP($J,"PSOCPF"),^TMP($J,"PSOCPFX"),^TMP($J,"PSOCPFE")
  1.  ; compile data to display here
  1.  N BDATE,EDATE,RXS,PAT,FILDT,END,RIEN,RSX,RFL,DFN,VADM,VAEL
  1.  S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
  1.  S RXS=$P(FILTERS(0),U,3),DFN=$P(FILTERS(0),U,4)
  1.  ;read only selected patients RX's
  1.  F RX=0:0 S RX=$O(^PS(55,DFN,"P",RX)) Q:'RX  D
  1.  . S RIEN=$P($G(^PS(55,DFN,"P",RX,0)),U)
  1.  . Q:'RIEN  Q:'$D(^PSRX(RIEN,0))
  1.  . I RXS,'$D(FILTERS(1,RIEN)) Q
  1.  . I '$D(^PSRX(RIEN,0)) Q
  1.  . ; Get this RX's 0 fill and refills for fill date info
  1.  . ;PSO 636 Do not QUIT when 0 fill is out of date range
  1.  . ;I $D(^PSRX(RIEN,2)) S FILDT=$P(^PSRX(RIEN,2),U,2) Q:(FILDT<BDATE)!(FILDT>EDATE)  D SORTRF     ;0 fill
  1.  . I $D(^PSRX(RIEN,2)) S FILDT=$P(^PSRX(RIEN,2),U,2),RFL=0 I (FILDT'<BDATE)&(FILDT'>EDATE) D SORTRF     ;0 fill
  1.  . F RFL=0:0 S RFL=$O(^PSRX(RIEN,1,RFL)) Q:'RFL  D
  1.  .. S FILDT=$P(^PSRX(RIEN,1,RFL,0),U) Q:(FILDT<BDATE)!(FILDT>EDATE)  D SORTRF                   ;x refills
  1.  Q
  1.  ;
  1. SORTRF ;Set fill number and call getdata
  1.  ;PSO 636 Use fill# from global not AD index
  1.  ;S RFL=$O(^PSRX("AD",FILDT,RIEN,"")) Q:'$D(^DPT(DFN,0))  D GETDATA(RIEN)
  1.  Q:'$D(^DPT(DFN,0))
  1.  D GETDATA(RIEN)
  1.  Q
  1.  ;
  1. GETDATA(RIEN) ;SET UP DATA FOR LIST MANAGER
  1.  ;pso*7*636 remove SC,SCP,MTS,MTSO,CPY
  1.  N PTNM,PID,MED,RX,IBST1,RNB,MIEN,DEBTOR
  1.  N DRG,BLNO,ARST,ARST1,ARTRN,X,MREC,IBN,IBND,PBIL
  1.  N PRIEN,PIBN,PCOPAY
  1.  S RX=$$GET1^DIQ(52,RIEN_",",.01,"E")
  1.  S DRG=$$GET1^DIQ(52,RIEN_",",6,"I"),MED=$$GET1^DIQ(52,RIEN_",",6,"O")
  1.  I DRG="" Q
  1.  D DEM^VADPT S PTNM=VADM(1),PID=$P(VADM(2),U,1),PID=$E(PTNM,1)_$E(PID,6,9)
  1.  ;PSO*7*636 remove SC,SCP,MTS,MTSD
  1.  ;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)
  1.  ;S MTSD=$$GET1^DIQ(2,DFN_",",999.2,"I")
  1.  ;S X=$$RXST^IBARXEU(DFN,DT),CPY=$P(X,U,2)
  1.  I RFL S IBN=$$GET1^DIQ(52.1,RFL_","_RIEN,9,"I")
  1.  I 'RFL S IBN=$$GET1^DIQ(52,RIEN_",",106,"I")
  1.  ;PSO*7*636 Select all RXs even when no billing number
  1.  ;I IBN="" S (PBIL,BLNO,ARTRN,PRIEN,ARST1,ARST,DEBTOR)=""  Q
  1.  S (PBIL,ARST1,ARST,BLNO,ARTRN,PBIL,PRIEN,PIBN,DEBTOR)=""
  1.  S BLNO=$$GET1^DIQ(350,IBN_",",.11,"I")
  1.  S ARTRN=$$GET1^DIQ(350,IBN_",",.12,"I")
  1.  ; if no AR TRANSACTION NUMBER look for PARENT CHARGE
  1.  I ARTRN="" S PIBN=$$GET1^DIQ(350,IBN_",",.09,"I")
  1.  ; PARENT CHARGE IBN doesn't match IBN
  1.  I PIBN'="",PIBN'=IBN D
  1.  . S ARTRN=$$GET1^DIQ(350,PIBN_",",.12,"I")
  1.  . ;PSO*7*636 remove CHARGE
  1.  . S ARST=$$GET1^DIQ(350,PIBN_",",.05,"I"),ARST1=$$GET1^DIQ(350,PIBN_",",.05,"O")
  1.  ; if a AR TRANSACTION NUMBER exists set BILL NUMBER from AR TRANSACTION to PBIL,PRIEN
  1.  I ARTRN'="" S (PBIL,PRIEN)=$$GET1^DIQ(433,ARTRN_",",.03,"I")
  1.  ; PARENT CHARGE IBN matches IBN
  1.  I PIBN'="",PIBN=IBN D
  1.  . ;get status from parent INTEGRATED BILLING ACTION
  1.  . S ARST=$$GET1^DIQ(350,PIBN_",",.05,"I"),ARST1=$$GET1^DIQ(350,PIBN_",",.05,"O")
  1.  ; If no BILNO and theres a AR TRANSACTION BILL NUMBER, set BLNO & DEBTOR from ACCOUNTS RECEIVABLE
  1.  I BLNO="",PBIL'="" S BLNO=$$GET1^DIQ(430,PBIL_",",.01),DEBTOR=$$GET1^DIQ(430,PBIL_",",9,"I")
  1.  ;PSO*7*636 DO NOT GET STATUS FROM ACCOUNTS RECEIVABLE
  1.  ;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")
  1.  I PRIEN'="",PIBN="",DEBTOR="" S DEBTOR=$$GET1^DIQ(430,PRIEN_",",9,"I")
  1.  ;PSO*7*636 Set Status (ARST1) to NOBILL if no status was found
  1.  ;I ARST="" S ARST=$$GET1^DIQ(350.21,IBN_",",.01,"I"),ARST1=$$GET1^DIQ(350.21,IBN_",",.01,"O")
  1.  ;GET STATUS FROM 350 NOT 350.21
  1.  I ARST="" S ARST=$$GET1^DIQ(350,IBN_",",.05,"I"),ARST1=$$GET1^DIQ(350,IBN_",",.05,"O")
  1.  I BLNO="" S ARST1="NOBILL#"
  1.  S PCOPAY=+$G(^PSRX(RIEN,"IB"))
  1.  ;PSO*7*636 Remove SC,SCP,MTSD,MTS,CPY Add PCOPAY
  1.  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
  1.  Q
  1.  ;
  1. CANCEL ; CANCEL COPAY STATUS
  1.  ;
  1.  D FULL^VALM1
  1.  N I,J,IBXX,VALMY,ECNT,NAME,GOTPAT,RC,IBFR,IBTO
  1.  S CNT=0
  1.  D EN^VALM2($G(XQORNOD(0)))
  1.  ;pso 636 Clear screen so all options work same
  1.  D CLEAR^VALM1
  1.  I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
  1.  . S IBXX=0 F  S IBXX=$O(VALMY(IBXX)) Q:'IBXX  D
  1.  .. S RC=$G(^TMP($J,"PSOCPFX",IBXX)),CNT=CNT+1
  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)
  1.  .. I '$D(PSOPAR) D ^PSOLSET
  1.  .. W !!,?17,"PATIENT: ",NAME
  1.  .. W !,?17,"Medication: ",MED
  1.  .. W !,?17,"RX: ",RX_"-"_RFL
  1.  .. D ICN^PSODPT($P(^PSRX(PSODA,0),"^",2))
  1.  .. S PSORXN=$P(^PSRX(PSODA,0),"^"),PREA="R"
  1.  .. S PCOPAY=$G(^PSRX(PSODA,"IB"))
  1.  .. ;PSO 636 Display msg and 'return to continue'
  1.  .. I '$D(^PSRX(PSODA,"IB")) D  Q
  1.  ... W !!,"Rx # ",$P($G(^PSRX(PSODA,0)),"^")," has no charge data...NO action taken."
  1.  ... D PAUSE^VALM1
  1.  .. I $P($G(^PSRX(PSODA,"PFS")),"^",2)="",$P(^PSRX(PSODA,"IB"),"^",2)'>0,$P(^PSRX(PSODA,"IB"),"^",4)'>0 D  Q
  1.  ... W !!,"Rx # ",$P($G(^PSRX(PSODA,0)),"^")," has no charge data...NO action taken."
  1.  ... D PAUSE^VALM1
  1.  .. D ASKCAN
  1.  D SORT ;592 - Reload data after update
  1.  D BLD^PSOCPF
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. RESET ; RESET/CANCEL COPAY STATUS
  1.  ;
  1.  D FULL^VALM1
  1.  N I,J,IBXX,VALMY,ECNT,NAME,GOTPAT,RC,IBFR,IBTO
  1.  S CNT=0
  1.  D EN^VALM2($G(XQORNOD(0)))
  1.  ;pso 636 Clear screen so all options work same
  1.  D CLEAR^VALM1
  1.  I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
  1.  . S IBXX=0 F  S IBXX=$O(VALMY(IBXX)) Q:'IBXX  D
  1.  .. S RC=$G(^TMP($J,"PSOCPFX",IBXX)),CNT=CNT+1
  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)
  1.  .. D STATUS(PSODA,RFL)
  1.  D SORT ;592 - Reload data after update
  1.  D BLD^PSOCPF
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. STATUS(PSODA,RFL) ; PROCESS STATUS CHANGE
  1.  N PSOIBQ,PREA,PSI,PSOCOMM,FLAG,PSOSUMM,PSONW,PSOINDPT,PSONEW,PSOOLD
  1.  S PSOSUMM=""
  1.  I '$D(PSOPAR) D ^PSOLSET
  1.  W !!,?17,"PATIENT: ",NAME
  1.  W !,?17,"Medication: ",MED
  1.  W !,?17,"RX: ",RX_"-"_RFL
  1.  ;
  1.  D ICN^PSODPT($P(^PSRX(PSODA,0),"^",2))
  1.  S PSORXN=$P(^PSRX(PSODA,0),"^"),PREA="R"
  1.  S PCOPAY=$G(^PSRX(PSODA,"IB"))
  1.  W !!,"Rx # ",PSORXN," is a ",$S(+PCOPAY:"Copay",1:"No Copay")," prescription"
  1.  S PSOLFIL=$$LF^PSOPFSU1(PSODA) D PFSA^PSOPFSU1(PSODA,PSOLFIL,3)  ;PSOCPC def PSOPFSA=1 if OP SC/EI's change.
  1.  D EXEMCHK^PSOCPC ; CHECK/CHANGE EXEMPTION FLAGS
  1.  S PSOIBQ=$G(^PSRX(PSODA,"IBQ"))
  1.  ;
  1.  I '$G(^PSRX(PSODA,"IB")),PSOIBQ'["1" D  G ASKCAN
  1.  . K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to reset the status to COPAY" D ^DIR K DIR
  1.  . I Y'=1 Q
  1.  . 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
  1.  . S PREA="R",PSOOLD="No Copay",PSONW="Copay",PSOCOMM="" D ACTLOG^PSOCPA
  1.  . S PSI=0,PSOCOMM="Copay status of this Rx has been reset to COPAY." D SETSUMM^PSOCPC
  1.  . S $P(^PSRX(PSODA,"IB"),"^")=1 ;Reset flag to COPAY
  1.  ;
  1.  I $G(^PSRX(PSODA,"IB")) D  G ASKCAN
  1.  . 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
  1.  . I Y'=1 Q
  1.  . 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
  1.  . S PREA="R",PSOOLD="Copay",PSONW="No Copay",PSOCOMM="" D ACTLOG^PSOCPA
  1.  . S PSI=0,PSOCOMM="Copay status of this Rx has been reset to NO COPAY." D SETSUMM^PSOCPC
  1.  . S $P(^PSRX(PSODA,"IB"),"^")="" ;Reset flag to NO COPAY
  1. ASKCAN D ASKCAN^PSOCPD
  1.  ;I $$FLAG(.PSOSUMM) S ^TMP($J,"PSOCPFC",NAME,PSODA,RFL)="Cancelled" ;592 - Removed this logic, all data is reloaded
  1.  D PRTSUMM^PSOCPB
  1. RESETE K PSODA,PSORXN,PSORSN,PSOREF,X,Y,PCOPAY,PREA,PSOCOMM,PSI
  1.  Q
  1.  ;
  1. EXPORT ; -- print excel spreadsheet.
  1.  I '$D(^TMP($J,"PSOCPF")) D BLD^PSOCPF S VALMBCK="R" Q
  1.  D CLEAR^VALM1,FULL^VALM1
  1.  S LCNT=0
  1.  D ^%ZISC
  1.  D DEVICE("EF")
  1.  ;
  1.  D BLD^PSOCPF
  1.  D PAUSE^VALM1
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. 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
  1.  U IO
  1.  N LCNT,PCE,REC,OUT,NAME,XX,BCNT,CNT,NXT,ZZ,ZZ1,ZZ2,OUT
  1.  N BDATE,EDATE,RIEN,RFL
  1.  S BDATE=$$FMTE^XLFDT($P(FILTERS,U,1),"2DZ")
  1.  S EDATE=$$FMTE^XLFDT($P(FILTERS,U,2),"2DZ")
  1.  D EXHDR
  1.  S LCNT=0,NAME=""
  1.  F  S NAME=$O(^TMP($J,"PSOCPFE",NAME)) Q:NAME=""  D
  1.  . S RIEN=0
  1.  . F  S RIEN=$O(^TMP($J,"PSOCPFE",NAME,RIEN)) Q:RIEN=""  D
  1.  .. S RFL=""
  1.  .. F  S RFL=$O(^TMP($J,"PSOCPFE",NAME,RIEN,RFL)) Q:RFL=""  D
  1.  ... S REC=^TMP($J,"PSOCPFE",NAME,RIEN,RFL)
  1.  ... W !,REC
  1.  W !,"END OF REPORT"
  1.  Q
  1.  ;
  1. DEVICE(TYPE) ; Ask user to select device
  1.  ;
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  N %ZIS,CRT,MAXCNT,POP,IOST,MAXCNT,IOSL,ZTREQ
  1.  W !,"NO QUEUING ALLOWED FOR THIS REPORT"
  1.  W !,"This report must have a line length of at least 256.",!
  1.  S %ZIS="M" D ^%ZIS G:POP ENQ
  1.  ; print report
  1.  I IOST["C-" S MAXCNT=IOSL-3,CRT=1
  1.  E  S MAXCNT=IOSL,CRT=0
  1.  ;
  1.  I TYPE="EF" U IO D EXCEL(FILTERS(0))
  1.  ;
  1.  D ^%ZISC
  1.  ; 
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  ;
  1. ENQ Q
  1.  ;
  1. EXHDR ; -- excel header
  1.  N HDR
  1.  ;^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
  1.  W !,"Reset/Cancel Report"
  1.  W !,"From ",BDATE," TO ",EDATE
  1.  ;PSO*7*636 remove SC,SCP
  1.  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"
  1.  W !,HDR
  1.  Q