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

PSOCPF.m

Go to the documentation of this file.
  1. PSOCPF ;BIR/BAA - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
  1. ;;7.0;OUTPATIENT PHARMACY;**463,592,618,636**;DEC 1997;Build 14
  1. ;
  1. EN ; -- main entry point for HELD CHARGES LIST
  1. ;
  1. ; add code to do filters here
  1. N FILTERS,PNAME
  1. ;PSO*7*618 MOVE NEWS FROM FILTERS
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y,IBDATES,DFN,R
  1. ;PSO*7*618 ADD NEWS FROM ASKRX
  1. N DIC,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N
  1. I '$$FILTER(.FILTERS) Q
  1. ;
  1. ; code to do sort
  1. D SORT
  1. ;
  1. K XQORS,VALMEVL D EN^VALM("PSO PATIENT MEDICATION LIST")
  1. D ^%ZISC
  1. Q
  1. ;
  1. HDR ; -- header code
  1. ;
  1. S VALM("TITLE")=" Patient Medications "
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. ; input - ^TMP($J,"PSOCPF")
  1. ; output - ^TMP("VALMAR",$J)
  1. N BDATE,EDATE,MEDSA,PAT,RXS
  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. D BLD
  1. Q
  1. ;
  1. SORT ; get the data
  1. N BDATE,EDATE,MEDS,PAT,RXS
  1. S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
  1. S MEDS=$P(FILTERS(0),U,3),PAT=$P(FILTERS(0),U,4)
  1. S RXS=$P(FILTERS(0),U,3)
  1. S ^TMP($J,"PSOCPFF",0)=FILTERS(0)
  1. ;
  1. D SORT^PSOCPF1
  1. Q
  1. ;
  1. BLD ; build data to display
  1. ; build display
  1. ; ^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_SC_U_SCP_U_MTSD_U_MTS_U_DFN_U_PBIL_U_ARST_U_PRIEN
  1. K ^TMP($J,"PSOCPFX"),^TMP($J,"PSOCPFE")
  1. K ^TMP("VALMAR",$J)
  1. N LINE,VCNT
  1. I '$D(^TMP($J,"PSOCPF")) D Q
  1. . S (VCNT,VALMCNT)=1
  1. . ;PSO*7*618 fix/rewrite add patient info
  1. . S NAME=$P($G(^DPT(+PAT,0)),U)
  1. . S LINE=$$SETL("","","",1,4)
  1. . S LINE=$$SETL(LINE,NAME,"",5,22)
  1. . D SET^VALM10(VCNT,LINE,VCNT)
  1. . S LINE=$$SETL("","","",1,7)
  1. . S LINE=$$SETL(LINE,"NO DATA FOUND FOR ENTERED CRITERIA","",8,50)
  1. . S VCNT=3
  1. . D SET^VALM10(VCNT,LINE,VCNT)
  1. N RFL,VCNT,MED,NAME,RFL,SC,SCP,FILDT,BLN,IBST1,RX,REC,VALMY,ARST1,BLNO
  1. N DFN,PBIL,PID,PRIEN,RIEN,RXO,RXS,SCO,SCOO,SCPO,DEBTOR,RXS
  1. S VALMCNT=0
  1. S (RIEN,VCNT)=0,(NAME,RFL)=""
  1. F S NAME=$O(^TMP($J,"PSOCPF",NAME)) Q:NAME="" D
  1. . F S RIEN=$O(^TMP($J,"PSOCPF",NAME,RIEN)) Q:RIEN="" D
  1. .. F S RFL=$O(^TMP($J,"PSOCPF",NAME,RIEN,RFL)) Q:RFL="" D
  1. ... S VCNT=VCNT+1
  1. ... S LINE=$$SETL("",VCNT,"",1,4) ;line#
  1. ... S REC=^TMP($J,"PSOCPF",NAME,RIEN,RFL),PID=$P(REC,U,2),ARST1=$P(REC,U,10),PBIL=$P(REC,U,16)
  1. ... S MED=$P(REC,U,3),RX=$P(REC,U,7),BLN=$P(REC,U,9),FILDT=$P(REC,U,8),DFN=$P(REC,U,15)
  1. ... ;PSO*7*636 remove CPY
  1. ... S PRIEN=$P(REC,U,18),DEBTOR=$P(REC,U,21)
  1. ... S ^TMP($J,"PSOCPFX",VCNT)=NAME_U_DFN_U_MED_U_RIEN_U_BLN_U_PRIEN_U_RFL_U_RX_U_DEBTOR
  1. ... S RXO="Rx#:"_RX_"-"_RFL
  1. ... S BLNO="BIL#:"_BLN
  1. ... ;PSO*7*636 Remove SC & SC% from report
  1. ... ;S SC=$P(REC,U,11),SCO=$S(SC=1:"YES",1:"NO"),SCOO="SC:"_SCO
  1. ... ;S SCP=$P(REC,U,12),SCPO="SC%:"_+SCP
  1. ... ;Add RX Status PSO 636
  1. ... S RXS=$P(REC,U,11),RXS=$S(RXS:"COPAY",1:"NO COPAY"),RXS="RX STATUS: "_RXS
  1. ... ;PSO*7*636 remove MTSD,MTS,CPYO
  1. ... ;S MTSD=$P(REC,U,13),MTO="DT:"_MTSD
  1. ... ;S MTS=$P(REC,U,14),MTSO="MT:"_MTS
  1. ... ;S CPYO="RX:"_CPY
  1. ... ;PSO*7*636 Remove SC,SC%,MTSD,MTS,CPY from report
  1. ... S ^TMP($J,"PSOCPFE",NAME,RIEN,RFL)=NAME_U_PID_U_MED_U_RX_"-"_RFL_U_$$FMTE^XLFDT(FILDT,"2DZ")_U_BLN_U_ARST1_U_RXS_U_U_U_U
  1. ... S LINE=$$SETL(LINE,NAME,"",5,22)
  1. ... S LINE=$$SETL(LINE,PID,"",28,6)
  1. ... S LINE=$$SETL(LINE,MED,"",35,16)
  1. ... S LINE=$$SETL(LINE,$$FMTE^XLFDT(FILDT,"2DZ"),"",53,8)
  1. ... S LINE=$$SETL(LINE,ARST1,"",62,17)
  1. ... S VALMCNT=VALMCNT+1
  1. ... D SET^VALM10(VALMCNT,LINE,VCNT)
  1. ... ;PSO*7*636 Remove SC & SC% from report
  1. ... ;S LINE=$$SETL("",SCOO,"",5,8)
  1. ... ;S LINE=$$SETL(LINE,SCPO,"",14,8)
  1. ... ;PSO*7*636 Add RX Status:
  1. ... S LINE=$$SETL("",RXS,"",6,20)
  1. ... ;PSO*7*636 move RX# label 1 space right
  1. ... S LINE=$$SETL(LINE,RXO,"",36,20)
  1. ... ;PSO*7*636 Move BIL# label to the left 8 spaces
  1. ... S LINE=$$SETL(LINE,BLNO,"",54,17)
  1. ... S VALMCNT=VALMCNT+1
  1. ... D SET^VALM10(VALMCNT,LINE,VCNT)
  1. ... ;PSO*7*636 remove mtso,mts,cpyo
  1. ... ;S LINE=$$SETL("",MTSO,"",5,20)
  1. ... ;S LINE=$$SETL(LINE,MTO,"",35,16)
  1. ... ;S LINE=$$SETL(LINE,CPYO,"",53,25)
  1. ... ;S VALMCNT=VALMCNT+1
  1. ... ;D SET^VALM10(VALMCNT,LINE,VCNT)
  1. ... ;PSO*7*636 No blank line between RXs
  1. ... ;S LINE=""
  1. ... ;S VALMCNT=VALMCNT+1
  1. ... ;D SET^VALM10(VALMCNT,LINE,VCNT)
  1. Q
  1. ;
  1. SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
  1. ; of the worklist
  1. ; Input: LINE - Current line being created
  1. ; DATA - Information to be added to the end of the current line
  1. ; LABEL - Label to describe the information being added
  1. ; COL - Column position in line to add information add
  1. ; LNG - Maximum length of data information to include on the line
  1. ; Returns: Line updated with added information
  1. S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
  1. Q LINE
  1. ;
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. K ^TMP($J,"PSOCPF")
  1. K ^TMP($J,"PSOCPFX")
  1. K ^TMP($J,"PSOCPFE")
  1. ;
  1. D CLEAR^VALM1,CLEAN^VALM10
  1. D ^%ZISC
  1. Q
  1. ;
  1. FILTER(FILTERS) ; filter display
  1. ; Sets an array of filters to determine which entries to include in display
  1. ; Input: None
  1. ; Output:
  1. ; Returns: 0 if the user entered '^' or timed out, 1 otherwise
  1. ; FILTERS(0) = from date ^ to date ^ 0 (all) 1 (selected) prescriptions ^ patient ^
  1. ; 0 (no) 1 (yes) exclude canceled bills
  1. ; FILTERS(1,RX ien) = ""
  1. ;PSO*7*618 MOVE NEWS TO ENTRY OF ROUTINE
  1. ;N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y,IBDATES,DFN,R
  1. K FILTERS
  1. ;
  1. S DIC(0)="AEQMN",DIC="^DPT(",FIRST=1
  1. S PAT=$$ONEPAT()
  1. I PAT=-1 Q 0
  1. S PNAME=$P(PAT,U,2)
  1. S (DFN,PAT,$P(FILTERS(0),U,4))=$P(PAT,U,1)
  1. ;
  1. ; get date range
  1. S IBDATES="Fill Dates",IBDATES=$$FMDATES(IBDATES) I +IBDATES=0 Q 0 ;PSO 618 add +
  1. S $P(FILTERS(0),U,1)=$P(IBDATES,U,1)
  1. S $P(FILTERS(0),U,2)=$P(IBDATES,U,2)
  1. ;
  1. ; Prescription filter
  1. D ADDRX
  1. ;PSO 618 add DIRUT exit
  1. I $G(DIRUT)!(Y=-1) Q 0
  1. ;
  1. S ^TMP($J,"PSOCPFF",0)=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. ;
  1. D SHOWFILT(.FILTERS)
  1. I X="^" Q 0
  1. Q 1
  1. ;
  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. ;
  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 I Y<0!($P(Y,".",1)'?7N) G FMDQ
  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 I Y<0!($P(Y,".",1)'?7N) G FMDQ
  1. S DT1=DT2_U_$P(Y,".",1)
  1. FMDQ Q DT1
  1. ;
  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="",Y=""
  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. ;
  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. Q
  1. ;
  1. ONEPAT(DIC,IEN,FIRST) ; Prompts the user for a clinic or ward
  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 Patient
  1. ; null of no selection was made
  1. N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
  1. S DIC(0)="AEQMN",DIC="^DPT("
  1. S DIC("A")="Select Patient: "
  1. D ^DIC
  1. Q Y
  1. ;
  1. ;
  1. SHOWFILT(FILTERS) ;EP
  1. ; Displays the currently selected filter selections for the
  1. ; Held Charges ListManager display
  1. ; Input: FILTERS() - Array of filter settings. See FILTERS for a detailed
  1. ; explanation of the FILTERS array
  1. ; Output: Current Filter settings are displayed
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IEN,IX,LEN,LINE,XX,PFLG,STDT,R,PAT,ENDT,STDT,I
  1. ;
  1. W !!,"Selected Patient: ",PNAME
  1. ;
  1. S STDT=$P(FILTERS(0),U),ENDT=$P(FILTERS(0),U,2)
  1. W !,"Show From Date: ",$S(STDT=0:"First",1:$$FMTE^XLFDT(STDT,"2DZ"))
  1. W !," Thru Date: ",$$FMTE^XLFDT(ENDT,"2DZ")
  1. W !,"Show All Prescriptions or Selected Prescriptions: "
  1. W $S($P(FILTERS(0),U,3)=0:"All",1:"Selected")
  1. ;
  1. ; RX list (if any)
  1. I ($P(FILTERS(0),U,3)=1) D
  1. . S LINE="Prescriptions to Display: "
  1. . S IEN=0,PFLG=0
  1. . F S IEN=$O(FILTERS(1,IEN)) Q:IEN="" D
  1. . . S XX=FILTERS(1,IEN)
  1. . . S LINE=LINE_$S(LINE="Prescriptions to Display: ":"",1:", ")_XX
  1. . W !,$$WRAP(.LINE,.PFLG,80)
  1. . F I=0:0 Q:'PFLG W !,?22,$$WRAP(.LINE,.PFLG,58)
  1. ;
  1. K DIR
  1. D PAUSE^VALM1
  1. Q
  1. ;
  1. WRAP(STR,FLG,CL) ;
  1. ; STR - STRING TO BE WRAPPED PASSED IN BY REFERENCE SO IT CONTAINS THE REMAING PORTION OF STRING
  1. ; FLG - FLAG TO INDICATE WRAPPING NEEDS TO OCCUR
  1. ; CL - COLUMN LENGTH
  1. ;
  1. ; NO WRAPPING REQUIRED
  1. I $L(STR)'>CL S FLG=0 Q STR
  1. S FLG=1
  1. N A,B,C
  1. ; POSITION AFTER COLUMN WIDTH BREAK IS A SPACE
  1. I $E(STR,CL+1)=" " S B=$E(STR,1,CL),STR=$E(STR,CL+2,999) Q B
  1. S A=$E(STR,1,CL)
  1. ; NO SPACES WITHIN COLUMN WITH, JUST BREAK AT COLUMN WIDTH
  1. I $L(A," ")=1 S STR=$E(STR,CL+1,999) Q A
  1. ; BREAK ON LAST SEMICOLON PIECE WITHIN COLUMN WIDTH
  1. S C=$L(A," ")
  1. S B=$P(A," ",1,C-1)
  1. S STR=$P(A," ",C)_$E(STR,CL+1,999)
  1. Q B