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

PSOCPF2.m

Go to the documentation of this file. 
  1. PSOCPF2 ;BIR/BAA - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
  1.  ;;7.0;OUTPATIENT PHARMACY;**463,618,636**;DEC 1997;Build 14
  1.  ;
  1.  Q
  1.  ;^TMP($J,"PSOCPFX",VCNT)=NAME_U_DFN_U_MED_U_RIEN_U_BLN_U_PRIEN_U_RFL_U_RX_U_DEBTOR
  1.  ;
  1. PATACP ; ACTION - Account Profile (AP)
  1.  D FULL^VALM1
  1.  D EN^VALM2($G(XQORNOD(0)))
  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.  .. N RCDEBTDA
  1.  .. S RC=$G(^TMP($J,"PSOCPFX",IBXX))
  1.  .. S RCDEBTDA=$P(RC,U,9)  ;Need DEBTOR for AP
  1.  .. I 'RCDEBTDA D  Q
  1.  ... W !!,"There is no Bill associated with this entry."
  1.  ... D PAUSE^VALM1
  1.  .. D EN^VALM("RCDP ACCOUNT PROFILE")
  1.  D BLD^PSOCPF
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. BILPRO ; view BILL PROFILE
  1.  D FULL^VALM1
  1.  N I,J,IBXX,VALMY,ECNT,REC,RCBILLDA
  1.  D EN^VALM2($G(XQORNOD(0)))
  1.  ;PSO*7*636 
  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 REC=$G(^TMP($J,"PSOCPFX",IBXX))
  1.  .. S RCBILLDA=$P(REC,U,6)
  1.  .. I RCBILLDA="" D  Q
  1.  ... W !!,"There is no Bill associated with this entry."
  1.  ... D PAUSE^VALM1
  1.  .. D EN^VALM("RCDP BILL PROFILE")
  1.  D BLD^PSOCPF
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. TPJI ; view THIRD PARTY JOIN INQUIRY
  1.  D FULL^VALM1
  1.  N I,J,IBXX,VALMY,ECNT,DFN,GOPAT,REC
  1.  D EN^VALM2($G(XQORNOD(0)))
  1.  I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
  1.  . S IBXX=0 F  S IBXX=$O(VALMY(IBXX)) Q:'IBXX  D
  1.  .. S REC=$G(^TMP($J,"PSOCPFX",IBXX))
  1.  .. S DFN=$P(REC,U,2)
  1.  .. D EN^VALM("IBJT ACTIVE LIST")
  1.  D BLD^PSOCPF
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. BILINQ ; view PATIENT BILLING INQUIRY
  1.  D FULL^VALM1
  1.  N I,J,IBXX,VALMY,ECNT,DFN,GOPAT,IBIL,REC,IBFULL,IBIFN
  1.  D EN^VALM2($G(XQORNOD(0)))
  1.  ;PSO*7*636 
  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 REC=$G(^TMP($J,"PSOCPFX",IBXX))
  1.  .. S IBIL=$P(REC,U,5),IBFULL=1,IBIFN=""
  1.  .. I IBIL="" D  Q
  1.  ... W !!,"There is no Bill associated with this entry."
  1.  ... D PAUSE^VALM1
  1.  .. D EN^IBOLK
  1.  D BLD^PSOCPF
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. PATINQ ; view PATIENT INQUIRY
  1.  D FULL^VALM1
  1.  N I,J,IBXX,VALMY,ECNT,DFN,GOPAT,REC
  1.  D EN^VALM2($G(XQORNOD(0)))
  1.  I $D(VALMY),$D(^TMP($J,"PSOCPF")) D
  1.  . S IBXX=0 F  S IBXX=$O(VALMY(IBXX)) Q:'IBXX  D
  1.  .. S REC=$G(^TMP($J,"PSOCPFX",IBXX))
  1.  .. S DFN=$P(REC,U,2)
  1.  .. D EN^DGRPD
  1.  D BLD^PSOCPF
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. NP ; -- change patient,date and prescriptions.
  1.  N VALMQUIT,IBDFN,PAT,DFN,SDATE,TDATE,IBDATES,SAVFIL
  1.  ;PSO*7*618 MOVE NEW HERE FROM ASKRX
  1.  N DIC,DIR,DIRUT,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N,X,XX,Y
  1.  D FULL^VALM1
  1.  I $D(^TMP($J,"PSOCPFF",0)) S FILTERS(0)=^TMP($J,"PSOCPFF",0),SAVFIL(0)=FILTERS(0)
  1.  S R=""
  1.  F  S R=$O(^TMP($J,"PSOCPFF",1,R)) Q:R=""  S SAVFIL(1,R)=^TMP($J,"PSOCPFF",1,R)
  1.  ;
  1.  ;K ^TMP($J,"PSOCPFF") ;pso*7*618 fix/rewrite
  1.  S IBDFN=$P(FILTERS(0),U,4)
  1.  S PAT=$$ONEPAT^PSOCPF()
  1.  I PAT=-1 D RESET S VALMBCK="R" G NPQ
  1.  S (DFN,$P(FILTERS(0),U,4))=+PAT
  1.  S SDATE=$P(FILTERS(0),U,1)
  1.  S TDATE=$P(FILTERS(0),U,2)
  1.  ;PSO*7*618 FIX/REWRITE CALL FMDATES IN THIS ROUTINE
  1.  S IBDATES="Fill Dates",IBDATES=$$FMDATES(IBDATES,SDATE,TDATE)
  1.  ;PSO *7*618 FIX/REWRITE Return to LM screen
  1.  I IBDATES=-1 D RESET S VALMBCK="R" G NPQ
  1.  I $D(VALMQUIT) D RESET S VALMBCK="R" G NPQ
  1.  ;PSO*7*618 CALL ADDRX IN THIS ROUTINE
  1.  D ADDRX^PSOCPF2
  1.  ;PSO *7*618 FIX/REWRITE Return to LM screen
  1.  I Y="^"!(Y<0) D RESET S VALMBCK="R" G NPQ
  1.  S $P(FILTERS(0),U,1)=$P(IBDATES,U,1),$P(FILTERS(0),U,2)=$P(IBDATES,U,2)
  1.  S ^TMP($J,"PSOCPF")=FILTERS(0)
  1.  S R=""
  1.  F  S R=$O(FILTERS(1,R)) Q:R=""  S ^TMP($J,"PSOCPFF",1,R)=FILTERS(1,R)
  1.  W !,"Please be patient while I gather the requested data.",!
  1.  S VALMBG=1 D SORT^PSOCPF1,HDR^PSOCPF,BLD^PSOCPF
  1.  S VALMBCK="R"
  1. NPQ Q
  1.  ;
  1. RESET ; Reset filters to current patient
  1.  S (DFN,$P(FILTERS(0),U,4))=IBDFN
  1.  S FILTERS(0)=$G(SAVFIL(0)) ;pso*7*618 ADD $g
  1.  S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
  1.  S RXS=$P(FILTERS(0),U,3),PAT=$P(FILTERS(0),U,4)
  1.  S ^TMP($J,"PSOCPFF",0)=FILTERS(0)
  1.  S R=""
  1.  F  S R=$O(SAVFIL(1,R)) Q:R=""  S (FILTERS(1,R),^TMP($J,"PSOCPFF",1,R))=SAVFIL(1,R)
  1.  Q
  1.  ;PSO*7*618 FIX/REWRITE - COPIED FROM PSOCPF
  1. FMDATES(PROMPT,SDT,EDT) ; ask for date range
  1.  N %DT,X,Y,DT1,DT2,IB0,IB1,IB2
  1.  S DT1="",IB1="Start with date entered: ",IB2="Go to date entered: "
  1.  I $G(PROMPT)'="" S IB1="Start with "_PROMPT_": ",IB2="Go to "_PROMPT_": "
  1.  I $D(SDT) K %DT S Y=SDT D DD^%DT S %DT("B")=Y
  1.  ;
  1.  S %DT="AEX",%DT("A")=IB1 D ^%DT K %DT
  1.  ;PSO 618 PASS -1 BACK
  1.  I Y<0!($P(Y,".",1)'?7N) Q -1
  1.  S (%DT(0),DT2)=$P(Y,".",1) I DT2'>DT,'$D(EDT) S %DT("B")="Today"
  1.  ; 
  1.  I $D(EDT) K %DT S Y=EDT D DD^%DT S %DT("B")=Y
  1.  ;
  1.  S %DT="AEX",%DT("A")=IB2 D ^%DT K %DT
  1.  ;PSO 618 PASS -1 BACK
  1.  I Y<0!($P(Y,".",1)'?7N) Q -1
  1.  S DT1=DT2_U_$P(Y,".",1)
  1. FMDQ Q DT1
  1.  ;
  1.  ;PSO*7*618 FIX/REWRITE COPIED FROM PSOCPF
  1. ADDRX ; 
  1.  ; Prescription filter
  1.  S DIR(0)="S",DIR("A")="Select(A)ll or (S)elected Prescription(s)",DIR("B")="All"
  1.  S DIR("?",1)="Enter 'A' to not filter by Prescriptions."
  1.  S DIR("?")="Enter 'S' to view entries for selected Prescription(s)."
  1.  S $P(DIR(0),U,2)="A:All Prescriptions;S:Selected Prescriptions"
  1.  W ! D ^DIR K DIR
  1.  ;PSO 618 add DIRUT exit
  1.  I $G(DIRUT)!(Y=-1) Q
  1.  S X=$$UP^XLFSTR(X)
  1.  S $P(FILTERS(0),U,3)=$S(Y="A":0,1:1)
  1.  ;
  1.  I $P(FILTERS(0),U,3)=1 D ASKRX(.FILTERS)
  1.  ;
  1.  Q
  1. ASKRX(FILTERS)   ; Sets a list of PrescriptionS to be displayed
  1.  ; Input:   FILTERS - Current Array of filter settings
  1.  ; Output:  FILTERS - Updated Array of filter settings
  1.  ;PSO*7*618 MOVE TO NP
  1.  ;N DIC,DIR,DIRUT,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N,X,XX,Y
  1.  S DIC=52,DIC(0)="AEQMN",FIRST=1
  1.  K FILTERS(1)
  1.  F  D  Q:+IEN<1
  1.  . D ONERX(.DIC,.IEN,.FIRST)                   ; One Prescription prompt
  1.  . Q:+IEN<1
  1.  . S PSOIENS($P(IEN,U,2))=$P(IEN,U,1)
  1.  . S PSOIENS2($P(IEN,U,1))=$P(IEN,U,2)
  1.  I '$D(PSOIENS) S $P(FILTERS(0),U,3)=0 Q
  1.  ;
  1.  ; Set the filter node responses in alphabetical order
  1.  S XX=""
  1.  F  D  Q:XX=""
  1.  . S XX=$O(PSOIENS(XX))
  1.  . Q:XX=""
  1.  . S N=PSOIENS(XX)
  1.  . S FILTERS(1,N)=XX
  1.  Q
  1. ONERX(DIC,IEN,FIRST)  ; Prompts the user for a Medication
  1.  ; Input:   DIC     - Variable/Array of settings needed for ^DIC call
  1.  ;          FIRST   - Set to 1 initially and then 0 for subsequent calls
  1.  ; Output:  FIRST   - Set to 0
  1.  ;          IEN     - IEN of the selected Division
  1.  ;                    null of no selection was made
  1.  S DIC("A")=$S(FIRST:"Select a Prescription: ",1:"Select Another Prescription: ")
  1.  D ^DIC
  1.  S FIRST=0,IEN=Y
  1.  I Y=-1 D RESET S VALMBCK="R" Q
  1.  Q