- PSOCPF ;BIR/BAA - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
- ;;7.0;OUTPATIENT PHARMACY;**463,592,618,636**;DEC 1997;Build 14
- ;
- EN ; -- main entry point for HELD CHARGES LIST
- ;
- ; add code to do filters here
- N FILTERS,PNAME
- ;PSO*7*618 MOVE NEWS FROM FILTERS
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y,IBDATES,DFN,R
- ;PSO*7*618 ADD NEWS FROM ASKRX
- N DIC,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N
- I '$$FILTER(.FILTERS) Q
- ;
- ; code to do sort
- D SORT
- ;
- K XQORS,VALMEVL D EN^VALM("PSO PATIENT MEDICATION LIST")
- D ^%ZISC
- Q
- ;
- HDR ; -- header code
- ;
- S VALM("TITLE")=" Patient Medications "
- Q
- ;
- INIT ; -- init variables and list array
- ; input - ^TMP($J,"PSOCPF")
- ; output - ^TMP("VALMAR",$J)
- N BDATE,EDATE,MEDSA,PAT,RXS
- S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
- S RXS=$P(FILTERS(0),U,3),PAT=$P(FILTERS(0),U,4)
- D BLD
- Q
- ;
- SORT ; get the data
- N BDATE,EDATE,MEDS,PAT,RXS
- S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
- S MEDS=$P(FILTERS(0),U,3),PAT=$P(FILTERS(0),U,4)
- S RXS=$P(FILTERS(0),U,3)
- S ^TMP($J,"PSOCPFF",0)=FILTERS(0)
- ;
- D SORT^PSOCPF1
- Q
- ;
- BLD ; build data to display
- ; build display
- ; ^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
- K ^TMP($J,"PSOCPFX"),^TMP($J,"PSOCPFE")
- K ^TMP("VALMAR",$J)
- N LINE,VCNT
- I '$D(^TMP($J,"PSOCPF")) D Q
- . S (VCNT,VALMCNT)=1
- . ;PSO*7*618 fix/rewrite add patient info
- . S NAME=$P($G(^DPT(+PAT,0)),U)
- . S LINE=$$SETL("","","",1,4)
- . S LINE=$$SETL(LINE,NAME,"",5,22)
- . D SET^VALM10(VCNT,LINE,VCNT)
- . S LINE=$$SETL("","","",1,7)
- . S LINE=$$SETL(LINE,"NO DATA FOUND FOR ENTERED CRITERIA","",8,50)
- . S VCNT=3
- . D SET^VALM10(VCNT,LINE,VCNT)
- N RFL,VCNT,MED,NAME,RFL,SC,SCP,FILDT,BLN,IBST1,RX,REC,VALMY,ARST1,BLNO
- N DFN,PBIL,PID,PRIEN,RIEN,RXO,RXS,SCO,SCOO,SCPO,DEBTOR,RXS
- S VALMCNT=0
- S (RIEN,VCNT)=0,(NAME,RFL)=""
- F S NAME=$O(^TMP($J,"PSOCPF",NAME)) Q:NAME="" D
- . F S RIEN=$O(^TMP($J,"PSOCPF",NAME,RIEN)) Q:RIEN="" D
- .. F S RFL=$O(^TMP($J,"PSOCPF",NAME,RIEN,RFL)) Q:RFL="" D
- ... S VCNT=VCNT+1
- ... S LINE=$$SETL("",VCNT,"",1,4) ;line#
- ... S REC=^TMP($J,"PSOCPF",NAME,RIEN,RFL),PID=$P(REC,U,2),ARST1=$P(REC,U,10),PBIL=$P(REC,U,16)
- ... 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)
- ... ;PSO*7*636 remove CPY
- ... S PRIEN=$P(REC,U,18),DEBTOR=$P(REC,U,21)
- ... S ^TMP($J,"PSOCPFX",VCNT)=NAME_U_DFN_U_MED_U_RIEN_U_BLN_U_PRIEN_U_RFL_U_RX_U_DEBTOR
- ... S RXO="Rx#:"_RX_"-"_RFL
- ... S BLNO="BIL#:"_BLN
- ... ;PSO*7*636 Remove SC & SC% from report
- ... ;S SC=$P(REC,U,11),SCO=$S(SC=1:"YES",1:"NO"),SCOO="SC:"_SCO
- ... ;S SCP=$P(REC,U,12),SCPO="SC%:"_+SCP
- ... ;Add RX Status PSO 636
- ... S RXS=$P(REC,U,11),RXS=$S(RXS:"COPAY",1:"NO COPAY"),RXS="RX STATUS: "_RXS
- ... ;PSO*7*636 remove MTSD,MTS,CPYO
- ... ;S MTSD=$P(REC,U,13),MTO="DT:"_MTSD
- ... ;S MTS=$P(REC,U,14),MTSO="MT:"_MTS
- ... ;S CPYO="RX:"_CPY
- ... ;PSO*7*636 Remove SC,SC%,MTSD,MTS,CPY from report
- ... 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
- ... S LINE=$$SETL(LINE,NAME,"",5,22)
- ... S LINE=$$SETL(LINE,PID,"",28,6)
- ... S LINE=$$SETL(LINE,MED,"",35,16)
- ... S LINE=$$SETL(LINE,$$FMTE^XLFDT(FILDT,"2DZ"),"",53,8)
- ... S LINE=$$SETL(LINE,ARST1,"",62,17)
- ... S VALMCNT=VALMCNT+1
- ... D SET^VALM10(VALMCNT,LINE,VCNT)
- ... ;PSO*7*636 Remove SC & SC% from report
- ... ;S LINE=$$SETL("",SCOO,"",5,8)
- ... ;S LINE=$$SETL(LINE,SCPO,"",14,8)
- ... ;PSO*7*636 Add RX Status:
- ... S LINE=$$SETL("",RXS,"",6,20)
- ... ;PSO*7*636 move RX# label 1 space right
- ... S LINE=$$SETL(LINE,RXO,"",36,20)
- ... ;PSO*7*636 Move BIL# label to the left 8 spaces
- ... S LINE=$$SETL(LINE,BLNO,"",54,17)
- ... S VALMCNT=VALMCNT+1
- ... D SET^VALM10(VALMCNT,LINE,VCNT)
- ... ;PSO*7*636 remove mtso,mts,cpyo
- ... ;S LINE=$$SETL("",MTSO,"",5,20)
- ... ;S LINE=$$SETL(LINE,MTO,"",35,16)
- ... ;S LINE=$$SETL(LINE,CPYO,"",53,25)
- ... ;S VALMCNT=VALMCNT+1
- ... ;D SET^VALM10(VALMCNT,LINE,VCNT)
- ... ;PSO*7*636 No blank line between RXs
- ... ;S LINE=""
- ... ;S VALMCNT=VALMCNT+1
- ... ;D SET^VALM10(VALMCNT,LINE,VCNT)
- Q
- ;
- SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
- ; of the worklist
- ; Input: LINE - Current line being created
- ; DATA - Information to be added to the end of the current line
- ; LABEL - Label to describe the information being added
- ; COL - Column position in line to add information add
- ; LNG - Maximum length of data information to include on the line
- ; Returns: Line updated with added information
- S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
- Q LINE
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K ^TMP($J,"PSOCPF")
- K ^TMP($J,"PSOCPFX")
- K ^TMP($J,"PSOCPFE")
- ;
- D CLEAR^VALM1,CLEAN^VALM10
- D ^%ZISC
- Q
- ;
- FILTER(FILTERS) ; filter display
- ; Sets an array of filters to determine which entries to include in display
- ; Input: None
- ; Output:
- ; Returns: 0 if the user entered '^' or timed out, 1 otherwise
- ; FILTERS(0) = from date ^ to date ^ 0 (all) 1 (selected) prescriptions ^ patient ^
- ; 0 (no) 1 (yes) exclude canceled bills
- ; FILTERS(1,RX ien) = ""
- ;PSO*7*618 MOVE NEWS TO ENTRY OF ROUTINE
- ;N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y,IBDATES,DFN,R
- K FILTERS
- ;
- S DIC(0)="AEQMN",DIC="^DPT(",FIRST=1
- S PAT=$$ONEPAT()
- I PAT=-1 Q 0
- S PNAME=$P(PAT,U,2)
- S (DFN,PAT,$P(FILTERS(0),U,4))=$P(PAT,U,1)
- ;
- ; get date range
- S IBDATES="Fill Dates",IBDATES=$$FMDATES(IBDATES) I +IBDATES=0 Q 0 ;PSO 618 add +
- S $P(FILTERS(0),U,1)=$P(IBDATES,U,1)
- S $P(FILTERS(0),U,2)=$P(IBDATES,U,2)
- ;
- ; Prescription filter
- D ADDRX
- ;PSO 618 add DIRUT exit
- I $G(DIRUT)!(Y=-1) Q 0
- ;
- S ^TMP($J,"PSOCPFF",0)=FILTERS(0)
- S R=""
- F S R=$O(FILTERS(1,R)) Q:R="" S ^TMP($J,"PSOCPFF",1,R)=FILTERS(1,R)
- ;
- D SHOWFILT(.FILTERS)
- I X="^" Q 0
- Q 1
- ;
- ADDRX ;
- ; Prescription filter
- S DIR(0)="S",DIR("A")="Select(A)ll or (S)elected Prescription(s)",DIR("B")="All"
- S DIR("?",1)="Enter 'A' to not filter by Prescriptions."
- S DIR("?")="Enter 'S' to view entries for selected Prescription(s)."
- S $P(DIR(0),U,2)="A:All Prescriptions;S:Selected Prescriptions"
- W ! D ^DIR K DIR
- ;PSO 618 add DIRUT exit
- I $G(DIRUT)!(Y=-1) Q
- S X=$$UP^XLFSTR(X)
- S $P(FILTERS(0),U,3)=$S(Y="A":0,1:1)
- ;
- I $P(FILTERS(0),U,3)=1 D ASKRX(.FILTERS)
- ;
- Q
- ;
- FMDATES(PROMPT,SDT,EDT) ; ask for date range
- N %DT,X,Y,DT1,DT2,IB0,IB1,IB2
- S DT1="",IB1="Start with date entered: ",IB2="Go to date entered: "
- I $G(PROMPT)'="" S IB1="Start with "_PROMPT_": ",IB2="Go to "_PROMPT_": "
- I $D(SDT) K %DT S Y=SDT D DD^%DT S %DT("B")=Y
- ;
- S %DT="AEX",%DT("A")=IB1 D ^%DT K %DT I Y<0!($P(Y,".",1)'?7N) G FMDQ
- S (%DT(0),DT2)=$P(Y,".",1) I DT2'>DT,'$D(EDT) S %DT("B")="Today"
- ;
- I $D(EDT) K %DT S Y=EDT D DD^%DT S %DT("B")=Y
- ;
- S %DT="AEX",%DT("A")=IB2 D ^%DT K %DT I Y<0!($P(Y,".",1)'?7N) G FMDQ
- S DT1=DT2_U_$P(Y,".",1)
- FMDQ Q DT1
- ;
- ASKRX(FILTERS) ; Sets a list of PrescriptionS to be displayed
- ; Input: FILTERS - Current Array of filter settings
- ; Output: FILTERS - Updated Array of filter settings
- ;PSO*7*618 MOVE TO NP
- ;N DIC,DIR,DIRUT,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N,X,XX,Y
- S DIC=52,DIC(0)="AEQMN",FIRST=1
- K FILTERS(1)
- F D Q:+IEN<1
- . D ONERX(.DIC,.IEN,.FIRST) ; One Prescription prompt
- . Q:+IEN<1
- . S PSOIENS($P(IEN,U,2))=$P(IEN,U,1)
- . S PSOIENS2($P(IEN,U,1))=$P(IEN,U,2)
- I '$D(PSOIENS) S $P(FILTERS(0),U,3)=0 Q
- ;
- ; Set the filter node responses in alphabetical order
- S XX="",Y=""
- F D Q:XX=""
- . S XX=$O(PSOIENS(XX))
- . Q:XX=""
- . S N=PSOIENS(XX)
- . S FILTERS(1,N)=XX
- Q
- ;
- ONERX(DIC,IEN,FIRST) ; Prompts the user for a Medication
- ; Input: DIC - Variable/Array of settings needed for ^DIC call
- ; FIRST - Set to 1 initially and then 0 for subsequent calls
- ; Output: FIRST - Set to 0
- ; IEN - IEN of the selected Division
- ; null of no selection was made
- S DIC("A")=$S(FIRST:"Select a Prescription: ",1:"Select Another Prescription: ")
- D ^DIC
- S FIRST=0,IEN=Y
- Q
- ;
- ONEPAT(DIC,IEN,FIRST) ; Prompts the user for a clinic or ward
- ; Input: DIC - Variable/Array of settings needed for ^DIC call
- ; FIRST - Set to 1 initially and then 0 for subsequent calls
- ; Output: FIRST - Set to 0
- ; IEN - IEN of the selected Patient
- ; null of no selection was made
- N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
- S DIC(0)="AEQMN",DIC="^DPT("
- S DIC("A")="Select Patient: "
- D ^DIC
- Q Y
- ;
- ;
- SHOWFILT(FILTERS) ;EP
- ; Displays the currently selected filter selections for the
- ; Held Charges ListManager display
- ; Input: FILTERS() - Array of filter settings. See FILTERS for a detailed
- ; explanation of the FILTERS array
- ; Output: Current Filter settings are displayed
- ;
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IEN,IX,LEN,LINE,XX,PFLG,STDT,R,PAT,ENDT,STDT,I
- ;
- W !!,"Selected Patient: ",PNAME
- ;
- S STDT=$P(FILTERS(0),U),ENDT=$P(FILTERS(0),U,2)
- W !,"Show From Date: ",$S(STDT=0:"First",1:$$FMTE^XLFDT(STDT,"2DZ"))
- W !," Thru Date: ",$$FMTE^XLFDT(ENDT,"2DZ")
- W !,"Show All Prescriptions or Selected Prescriptions: "
- W $S($P(FILTERS(0),U,3)=0:"All",1:"Selected")
- ;
- ; RX list (if any)
- I ($P(FILTERS(0),U,3)=1) D
- . S LINE="Prescriptions to Display: "
- . S IEN=0,PFLG=0
- . F S IEN=$O(FILTERS(1,IEN)) Q:IEN="" D
- . . S XX=FILTERS(1,IEN)
- . . S LINE=LINE_$S(LINE="Prescriptions to Display: ":"",1:", ")_XX
- . W !,$$WRAP(.LINE,.PFLG,80)
- . F I=0:0 Q:'PFLG W !,?22,$$WRAP(.LINE,.PFLG,58)
- ;
- K DIR
- D PAUSE^VALM1
- Q
- ;
- WRAP(STR,FLG,CL) ;
- ; STR - STRING TO BE WRAPPED PASSED IN BY REFERENCE SO IT CONTAINS THE REMAING PORTION OF STRING
- ; FLG - FLAG TO INDICATE WRAPPING NEEDS TO OCCUR
- ; CL - COLUMN LENGTH
- ;
- ; NO WRAPPING REQUIRED
- I $L(STR)'>CL S FLG=0 Q STR
- S FLG=1
- N A,B,C
- ; POSITION AFTER COLUMN WIDTH BREAK IS A SPACE
- I $E(STR,CL+1)=" " S B=$E(STR,1,CL),STR=$E(STR,CL+2,999) Q B
- S A=$E(STR,1,CL)
- ; NO SPACES WITHIN COLUMN WITH, JUST BREAK AT COLUMN WIDTH
- I $L(A," ")=1 S STR=$E(STR,CL+1,999) Q A
- ; BREAK ON LAST SEMICOLON PIECE WITHIN COLUMN WIDTH
- S C=$L(A," ")
- S B=$P(A," ",1,C-1)
- S STR=$P(A," ",C)_$E(STR,CL+1,999)
- Q B
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPF 10589 printed Feb 18, 2025@23:52:20 Page 2
- 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
- +2 ;
- EN ; -- main entry point for HELD CHARGES LIST
- +1 ;
- +2 ; add code to do filters here
- +3 NEW FILTERS,PNAME
- +4 ;PSO*7*618 MOVE NEWS FROM FILTERS
- +5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y,IBDATES,DFN,R
- +6 ;PSO*7*618 ADD NEWS FROM ASKRX
- +7 NEW DIC,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N
- +8 IF '$$FILTER(.FILTERS)
- QUIT
- +9 ;
- +10 ; code to do sort
- +11 DO SORT
- +12 ;
- +13 KILL XQORS,VALMEVL
- DO EN^VALM("PSO PATIENT MEDICATION LIST")
- +14 DO ^%ZISC
- +15 QUIT
- +16 ;
- HDR ; -- header code
- +1 ;
- +2 SET VALM("TITLE")=" Patient Medications "
- +3 QUIT
- +4 ;
- INIT ; -- init variables and list array
- +1 ; input - ^TMP($J,"PSOCPF")
- +2 ; output - ^TMP("VALMAR",$J)
- +3 NEW BDATE,EDATE,MEDSA,PAT,RXS
- +4 SET BDATE=$PIECE(FILTERS(0),U,1)
- SET EDATE=$PIECE(FILTERS(0),U,2)
- +5 SET RXS=$PIECE(FILTERS(0),U,3)
- SET PAT=$PIECE(FILTERS(0),U,4)
- +6 DO BLD
- +7 QUIT
- +8 ;
- SORT ; get the data
- +1 NEW BDATE,EDATE,MEDS,PAT,RXS
- +2 SET BDATE=$PIECE(FILTERS(0),U,1)
- SET EDATE=$PIECE(FILTERS(0),U,2)
- +3 SET MEDS=$PIECE(FILTERS(0),U,3)
- SET PAT=$PIECE(FILTERS(0),U,4)
- +4 SET RXS=$PIECE(FILTERS(0),U,3)
- +5 SET ^TMP($JOB,"PSOCPFF",0)=FILTERS(0)
- +6 ;
- +7 DO SORT^PSOCPF1
- +8 QUIT
- +9 ;
- BLD ; build data to display
- +1 ; build display
- +2 ; ^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
- +3 KILL ^TMP($JOB,"PSOCPFX"),^TMP($JOB,"PSOCPFE")
- +4 KILL ^TMP("VALMAR",$JOB)
- +5 NEW LINE,VCNT
- +6 IF '$DATA(^TMP($JOB,"PSOCPF"))
- Begin DoDot:1
- +7 SET (VCNT,VALMCNT)=1
- +8 ;PSO*7*618 fix/rewrite add patient info
- +9 SET NAME=$PIECE($GET(^DPT(+PAT,0)),U)
- +10 SET LINE=$$SETL("","","",1,4)
- +11 SET LINE=$$SETL(LINE,NAME,"",5,22)
- +12 DO SET^VALM10(VCNT,LINE,VCNT)
- +13 SET LINE=$$SETL("","","",1,7)
- +14 SET LINE=$$SETL(LINE,"NO DATA FOUND FOR ENTERED CRITERIA","",8,50)
- +15 SET VCNT=3
- +16 DO SET^VALM10(VCNT,LINE,VCNT)
- End DoDot:1
- QUIT
- +17 NEW RFL,VCNT,MED,NAME,RFL,SC,SCP,FILDT,BLN,IBST1,RX,REC,VALMY,ARST1,BLNO
- +18 NEW DFN,PBIL,PID,PRIEN,RIEN,RXO,RXS,SCO,SCOO,SCPO,DEBTOR,RXS
- +19 SET VALMCNT=0
- +20 SET (RIEN,VCNT)=0
- SET (NAME,RFL)=""
- +21 FOR
- SET NAME=$ORDER(^TMP($JOB,"PSOCPF",NAME))
- if NAME=""
- QUIT
- Begin DoDot:1
- +22 FOR
- SET RIEN=$ORDER(^TMP($JOB,"PSOCPF",NAME,RIEN))
- if RIEN=""
- QUIT
- Begin DoDot:2
- +23 FOR
- SET RFL=$ORDER(^TMP($JOB,"PSOCPF",NAME,RIEN,RFL))
- if RFL=""
- QUIT
- Begin DoDot:3
- +24 SET VCNT=VCNT+1
- +25 ;line#
- SET LINE=$$SETL("",VCNT,"",1,4)
- +26 SET REC=^TMP($JOB,"PSOCPF",NAME,RIEN,RFL)
- SET PID=$PIECE(REC,U,2)
- SET ARST1=$PIECE(REC,U,10)
- SET PBIL=$PIECE(REC,U,16)
- +27 SET MED=$PIECE(REC,U,3)
- SET RX=$PIECE(REC,U,7)
- SET BLN=$PIECE(REC,U,9)
- SET FILDT=$PIECE(REC,U,8)
- SET DFN=$PIECE(REC,U,15)
- +28 ;PSO*7*636 remove CPY
- +29 SET PRIEN=$PIECE(REC,U,18)
- SET DEBTOR=$PIECE(REC,U,21)
- +30 SET ^TMP($JOB,"PSOCPFX",VCNT)=NAME_U_DFN_U_MED_U_RIEN_U_BLN_U_PRIEN_U_RFL_U_RX_U_DEBTOR
- +31 SET RXO="Rx#:"_RX_"-"_RFL
- +32 SET BLNO="BIL#:"_BLN
- +33 ;PSO*7*636 Remove SC & SC% from report
- +34 ;S SC=$P(REC,U,11),SCO=$S(SC=1:"YES",1:"NO"),SCOO="SC:"_SCO
- +35 ;S SCP=$P(REC,U,12),SCPO="SC%:"_+SCP
- +36 ;Add RX Status PSO 636
- +37 SET RXS=$PIECE(REC,U,11)
- SET RXS=$SELECT(RXS:"COPAY",1:"NO COPAY")
- SET RXS="RX STATUS: "_RXS
- +38 ;PSO*7*636 remove MTSD,MTS,CPYO
- +39 ;S MTSD=$P(REC,U,13),MTO="DT:"_MTSD
- +40 ;S MTS=$P(REC,U,14),MTSO="MT:"_MTS
- +41 ;S CPYO="RX:"_CPY
- +42 ;PSO*7*636 Remove SC,SC%,MTSD,MTS,CPY from report
- +43 SET ^TMP($JOB,"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
- +44 SET LINE=$$SETL(LINE,NAME,"",5,22)
- +45 SET LINE=$$SETL(LINE,PID,"",28,6)
- +46 SET LINE=$$SETL(LINE,MED,"",35,16)
- +47 SET LINE=$$SETL(LINE,$$FMTE^XLFDT(FILDT,"2DZ"),"",53,8)
- +48 SET LINE=$$SETL(LINE,ARST1,"",62,17)
- +49 SET VALMCNT=VALMCNT+1
- +50 DO SET^VALM10(VALMCNT,LINE,VCNT)
- +51 ;PSO*7*636 Remove SC & SC% from report
- +52 ;S LINE=$$SETL("",SCOO,"",5,8)
- +53 ;S LINE=$$SETL(LINE,SCPO,"",14,8)
- +54 ;PSO*7*636 Add RX Status:
- +55 SET LINE=$$SETL("",RXS,"",6,20)
- +56 ;PSO*7*636 move RX# label 1 space right
- +57 SET LINE=$$SETL(LINE,RXO,"",36,20)
- +58 ;PSO*7*636 Move BIL# label to the left 8 spaces
- +59 SET LINE=$$SETL(LINE,BLNO,"",54,17)
- +60 SET VALMCNT=VALMCNT+1
- +61 DO SET^VALM10(VALMCNT,LINE,VCNT)
- +62 ;PSO*7*636 remove mtso,mts,cpyo
- +63 ;S LINE=$$SETL("",MTSO,"",5,20)
- +64 ;S LINE=$$SETL(LINE,MTO,"",35,16)
- +65 ;S LINE=$$SETL(LINE,CPYO,"",53,25)
- +66 ;S VALMCNT=VALMCNT+1
- +67 ;D SET^VALM10(VALMCNT,LINE,VCNT)
- +68 ;PSO*7*636 No blank line between RXs
- +69 ;S LINE=""
- +70 ;S VALMCNT=VALMCNT+1
- +71 ;D SET^VALM10(VALMCNT,LINE,VCNT)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +72 QUIT
- +73 ;
- SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
- +1 ; of the worklist
- +2 ; Input: LINE - Current line being created
- +3 ; DATA - Information to be added to the end of the current line
- +4 ; LABEL - Label to describe the information being added
- +5 ; COL - Column position in line to add information add
- +6 ; LNG - Maximum length of data information to include on the line
- +7 ; Returns: Line updated with added information
- +8 SET LINE=LINE_$JUSTIFY("",(COL-$LENGTH(LABEL)-$LENGTH(LINE)))_LABEL_$EXTRACT(DATA,1,LNG)
- +9 QUIT LINE
- +10 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 KILL ^TMP($JOB,"PSOCPF")
- +2 KILL ^TMP($JOB,"PSOCPFX")
- +3 KILL ^TMP($JOB,"PSOCPFE")
- +4 ;
- +5 DO CLEAR^VALM1
- DO CLEAN^VALM10
- +6 DO ^%ZISC
- +7 QUIT
- +8 ;
- FILTER(FILTERS) ; filter display
- +1 ; Sets an array of filters to determine which entries to include in display
- +2 ; Input: None
- +3 ; Output:
- +4 ; Returns: 0 if the user entered '^' or timed out, 1 otherwise
- +5 ; FILTERS(0) = from date ^ to date ^ 0 (all) 1 (selected) prescriptions ^ patient ^
- +6 ; 0 (no) 1 (yes) exclude canceled bills
- +7 ; FILTERS(1,RX ien) = ""
- +8 ;PSO*7*618 MOVE NEWS TO ENTRY OF ROUTINE
- +9 ;N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y,IBDATES,DFN,R
- +10 KILL FILTERS
- +11 ;
- +12 SET DIC(0)="AEQMN"
- SET DIC="^DPT("
- SET FIRST=1
- +13 SET PAT=$$ONEPAT()
- +14 IF PAT=-1
- QUIT 0
- +15 SET PNAME=$PIECE(PAT,U,2)
- +16 SET (DFN,PAT,$PIECE(FILTERS(0),U,4))=$PIECE(PAT,U,1)
- +17 ;
- +18 ; get date range
- +19 ;PSO 618 add +
- SET IBDATES="Fill Dates"
- SET IBDATES=$$FMDATES(IBDATES)
- IF +IBDATES=0
- QUIT 0
- +20 SET $PIECE(FILTERS(0),U,1)=$PIECE(IBDATES,U,1)
- +21 SET $PIECE(FILTERS(0),U,2)=$PIECE(IBDATES,U,2)
- +22 ;
- +23 ; Prescription filter
- +24 DO ADDRX
- +25 ;PSO 618 add DIRUT exit
- +26 IF $GET(DIRUT)!(Y=-1)
- QUIT 0
- +27 ;
- +28 SET ^TMP($JOB,"PSOCPFF",0)=FILTERS(0)
- +29 SET R=""
- +30 FOR
- SET R=$ORDER(FILTERS(1,R))
- if R=""
- QUIT
- SET ^TMP($JOB,"PSOCPFF",1,R)=FILTERS(1,R)
- +31 ;
- +32 DO SHOWFILT(.FILTERS)
- +33 IF X="^"
- QUIT 0
- +34 QUIT 1
- +35 ;
- ADDRX ;
- +1 ; Prescription filter
- +2 SET DIR(0)="S"
- SET DIR("A")="Select(A)ll or (S)elected Prescription(s)"
- SET DIR("B")="All"
- +3 SET DIR("?",1)="Enter 'A' to not filter by Prescriptions."
- +4 SET DIR("?")="Enter 'S' to view entries for selected Prescription(s)."
- +5 SET $PIECE(DIR(0),U,2)="A:All Prescriptions;S:Selected Prescriptions"
- +6 WRITE !
- DO ^DIR
- KILL DIR
- +7 ;PSO 618 add DIRUT exit
- +8 IF $GET(DIRUT)!(Y=-1)
- QUIT
- +9 SET X=$$UP^XLFSTR(X)
- +10 SET $PIECE(FILTERS(0),U,3)=$SELECT(Y="A":0,1:1)
- +11 ;
- +12 IF $PIECE(FILTERS(0),U,3)=1
- DO ASKRX(.FILTERS)
- +13 ;
- +14 QUIT
- +15 ;
- FMDATES(PROMPT,SDT,EDT) ; ask for date range
- +1 NEW %DT,X,Y,DT1,DT2,IB0,IB1,IB2
- +2 SET DT1=""
- SET IB1="Start with date entered: "
- SET IB2="Go to date entered: "
- +3 IF $GET(PROMPT)'=""
- SET IB1="Start with "_PROMPT_": "
- SET IB2="Go to "_PROMPT_": "
- +4 IF $DATA(SDT)
- KILL %DT
- SET Y=SDT
- DO DD^%DT
- SET %DT("B")=Y
- +5 ;
- +6 SET %DT="AEX"
- SET %DT("A")=IB1
- DO ^%DT
- KILL %DT
- IF Y<0!($PIECE(Y,".",1)'?7N)
- GOTO FMDQ
- +7 SET (%DT(0),DT2)=$PIECE(Y,".",1)
- IF DT2'>DT
- IF '$DATA(EDT)
- SET %DT("B")="Today"
- +8 ;
- +9 IF $DATA(EDT)
- KILL %DT
- SET Y=EDT
- DO DD^%DT
- SET %DT("B")=Y
- +10 ;
- +11 SET %DT="AEX"
- SET %DT("A")=IB2
- DO ^%DT
- KILL %DT
- IF Y<0!($PIECE(Y,".",1)'?7N)
- GOTO FMDQ
- +12 SET DT1=DT2_U_$PIECE(Y,".",1)
- FMDQ QUIT DT1
- +1 ;
- ASKRX(FILTERS) ; Sets a list of PrescriptionS to be displayed
- +1 ; Input: FILTERS - Current Array of filter settings
- +2 ; Output: FILTERS - Updated Array of filter settings
- +3 ;PSO*7*618 MOVE TO NP
- +4 ;N DIC,DIR,DIRUT,DIVS,DUOUT,FIRST,PSOIENS,PSOIENS2,IEN,N,X,XX,Y
- +5 SET DIC=52
- SET DIC(0)="AEQMN"
- SET FIRST=1
- +6 KILL FILTERS(1)
- +7 FOR
- Begin DoDot:1
- +8 ; One Prescription prompt
- DO ONERX(.DIC,.IEN,.FIRST)
- +9 if +IEN<1
- QUIT
- +10 SET PSOIENS($PIECE(IEN,U,2))=$PIECE(IEN,U,1)
- +11 SET PSOIENS2($PIECE(IEN,U,1))=$PIECE(IEN,U,2)
- End DoDot:1
- if +IEN<1
- QUIT
- +12 IF '$DATA(PSOIENS)
- SET $PIECE(FILTERS(0),U,3)=0
- QUIT
- +13 ;
- +14 ; Set the filter node responses in alphabetical order
- +15 SET XX=""
- SET Y=""
- +16 FOR
- Begin DoDot:1
- +17 SET XX=$ORDER(PSOIENS(XX))
- +18 if XX=""
- QUIT
- +19 SET N=PSOIENS(XX)
- +20 SET FILTERS(1,N)=XX
- End DoDot:1
- if XX=""
- QUIT
- +21 QUIT
- +22 ;
- ONERX(DIC,IEN,FIRST) ; Prompts the user for a Medication
- +1 ; Input: DIC - Variable/Array of settings needed for ^DIC call
- +2 ; FIRST - Set to 1 initially and then 0 for subsequent calls
- +3 ; Output: FIRST - Set to 0
- +4 ; IEN - IEN of the selected Division
- +5 ; null of no selection was made
- +6 SET DIC("A")=$SELECT(FIRST:"Select a Prescription: ",1:"Select Another Prescription: ")
- +7 DO ^DIC
- +8 SET FIRST=0
- SET IEN=Y
- +9 QUIT
- +10 ;
- ONEPAT(DIC,IEN,FIRST) ; Prompts the user for a clinic or ward
- +1 ; Input: DIC - Variable/Array of settings needed for ^DIC call
- +2 ; FIRST - Set to 1 initially and then 0 for subsequent calls
- +3 ; Output: FIRST - Set to 0
- +4 ; IEN - IEN of the selected Patient
- +5 ; null of no selection was made
- +6 ;Suppress PATIENT file fuzzy lookups
- NEW DPTNOFZY
- SET DPTNOFZY=1
- +7 SET DIC(0)="AEQMN"
- SET DIC="^DPT("
- +8 SET DIC("A")="Select Patient: "
- +9 DO ^DIC
- +10 QUIT Y
- +11 ;
- +12 ;
- SHOWFILT(FILTERS) ;EP
- +1 ; Displays the currently selected filter selections for the
- +2 ; Held Charges ListManager display
- +3 ; Input: FILTERS() - Array of filter settings. See FILTERS for a detailed
- +4 ; explanation of the FILTERS array
- +5 ; Output: Current Filter settings are displayed
- +6 ;
- +7 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,IEN,IX,LEN,LINE,XX,PFLG,STDT,R,PAT,ENDT,STDT,I
- +8 ;
- +9 WRITE !!,"Selected Patient: ",PNAME
- +10 ;
- +11 SET STDT=$PIECE(FILTERS(0),U)
- SET ENDT=$PIECE(FILTERS(0),U,2)
- +12 WRITE !,"Show From Date: ",$SELECT(STDT=0:"First",1:$$FMTE^XLFDT(STDT,"2DZ"))
- +13 WRITE !," Thru Date: ",$$FMTE^XLFDT(ENDT,"2DZ")
- +14 WRITE !,"Show All Prescriptions or Selected Prescriptions: "
- +15 WRITE $SELECT($PIECE(FILTERS(0),U,3)=0:"All",1:"Selected")
- +16 ;
- +17 ; RX list (if any)
- +18 IF ($PIECE(FILTERS(0),U,3)=1)
- Begin DoDot:1
- +19 SET LINE="Prescriptions to Display: "
- +20 SET IEN=0
- SET PFLG=0
- +21 FOR
- SET IEN=$ORDER(FILTERS(1,IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +22 SET XX=FILTERS(1,IEN)
- +23 SET LINE=LINE_$SELECT(LINE="Prescriptions to Display: ":"",1:", ")_XX
- End DoDot:2
- +24 WRITE !,$$WRAP(.LINE,.PFLG,80)
- +25 FOR I=0:0
- if 'PFLG
- QUIT
- WRITE !,?22,$$WRAP(.LINE,.PFLG,58)
- End DoDot:1
- +26 ;
- +27 KILL DIR
- +28 DO PAUSE^VALM1
- +29 QUIT
- +30 ;
- WRAP(STR,FLG,CL) ;
- +1 ; STR - STRING TO BE WRAPPED PASSED IN BY REFERENCE SO IT CONTAINS THE REMAING PORTION OF STRING
- +2 ; FLG - FLAG TO INDICATE WRAPPING NEEDS TO OCCUR
- +3 ; CL - COLUMN LENGTH
- +4 ;
- +5 ; NO WRAPPING REQUIRED
- +6 IF $LENGTH(STR)'>CL
- SET FLG=0
- QUIT STR
- +7 SET FLG=1
- +8 NEW A,B,C
- +9 ; POSITION AFTER COLUMN WIDTH BREAK IS A SPACE
- +10 IF $EXTRACT(STR,CL+1)=" "
- SET B=$EXTRACT(STR,1,CL)
- SET STR=$EXTRACT(STR,CL+2,999)
- QUIT B
- +11 SET A=$EXTRACT(STR,1,CL)
- +12 ; NO SPACES WITHIN COLUMN WITH, JUST BREAK AT COLUMN WIDTH
- +13 IF $LENGTH(A," ")=1
- SET STR=$EXTRACT(STR,CL+1,999)
- QUIT A
- +14 ; BREAK ON LAST SEMICOLON PIECE WITHIN COLUMN WIDTH
- +15 SET C=$LENGTH(A," ")
- +16 SET B=$PIECE(A," ",1,C-1)
- +17 SET STR=$PIECE(A," ",C)_$EXTRACT(STR,CL+1,999)
- +18 QUIT B