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 Jan 18, 2025@03:27:03 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
