IBJDF4 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT ;15-APR-00
;;2.0;INTEGRATED BILLING;**123,204,220,568,618,705,739**;21-MAR-94;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to 433.001 in ICR #7321
;
EN ; - Option entry point.
S IBEXCEL=0
; get suspension types from file 433.001 IB*2.0*705
N I,LAST,SUSCODE,SUSIEN,X
K IBSUS
S SUSCODE="" F S SUSCODE=$O(^PRCA(433.001,"B",SUSCODE)) Q:SUSCODE="" D
.S SUSIEN=$O(^PRCA(433.001,"B",SUSCODE,"")) Q:'SUSIEN
.S IBSUS(SUSCODE)=$$GET1^DIQ(433.001,SUSIEN_",",.02)
.Q
S LAST=$O(IBSUS(""),-1),IBSUS(LAST+1)="NONE"
S LAST=LAST+2,IBSUS(LAST)="ALL OF THE ABOVE"
;
; - Select AR categories to print.
S IBPRT="Choose which type of receivables to print:"
K IBOPT
S IBOPT(1)="EMERGENCY/HUMANITARIAN"
S IBOPT(2)="INELIGIBLE"
S IBOPT(3)="C-MEANS TEST & RX COPAY"
S IBOPT(4)="LONG TERM CARE COPAY"
S IBOPT(5)="COMMUNITY CARE COPAY"
S IBOPT(6)="ALL OF THE ABOVE"
S IBSEL=$$MLTP^IBJD(IBPRT,.IBOPT,1) I 'IBSEL G ENQ
;
STA ; - Choose bill status.
W !!,"Run report for (A)CTIVE ARs, (S)USPENDED ARs, or (B)OTH: B// "
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="B" S X=$E(X)
I "AaBbSs"'[X S IBOFF=1 D HELP^IBJDF4H G STA
S IBSTA=$S("Aa"[X:"A","Ss"[X:"S",1:"B")
W " ",$S(IBSTA="A":"ACTIVE",IBSTA="S":"SUSPENDED",1:"BOTH")
;
SUSTYP ;If SUSPENDED is chosen, prompt for which suspended bills to display IB*2.0*568/DRF
I IBSTA="S" D
. S IBPRT="Choose which suspended types to print:"
. S IBSELST=$$MLTP0(IBPRT,.IBSUS,1)
I IBSTA="S",IBSELST="" G ENQ
;
; - Select a detailed or summary report.
D DS G ENQ:IBRPT["^"
I IBRPT="S"!(IBRPT="O") D G RC
. S IBSN="N",IBSNA="ALL",IBSNF="",IBSNL="zzzzz",IBSMN="A"
;
; - Determine sorting (By name or Last 4 SSN)
S IBSN="N" ;IB*2.0*739 force sorting by NAME
;
; - Determine the range
S X=$$INTV^IBJD("PATIENT "_$S(IBSN="N":"NAME",1:"LAST 4")) G ENQ:X="^"
S IBSNF=$P(X,"^",1),IBSNL=$P(X,"^",2),IBSNA=$P(X,"^",3)
;
AGE ; - Determine if the active receivable must be within an age range.
W !!,"Include (A)LL ",$S(IBSTA="A":"active ",IBSTA="S":"suspended ",1:""),"ARs or those within an AGE (R)ANGE: ALL// "
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
I "ARar"'[X S IBOFF=9 D HELP^IBJDF4H G AGE
S IBSMN=$S("Rr"[X:"R",1:"A") W " ",$S(IBSMN="R":"RANGE",1:"ALL")
I IBSMN="A" G AMT
;
; - Determine the active receivable age range.
W !,"EXAMPLE Range: 31-60 days"
S DIR(0)="NA^1:99999"
S DIR("A")="Enter the minimum age of the receivable: "
S DIR("T")=DTIME,DIR("?")="^S IBOFF=16 D HELP^IBJDF4H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSMN=+Y W " ",IBSMN," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
;
S DIR(0)="NA^"_IBSMN_":99999"
S DIR("A")="Enter the maximum age of the receivable: "
S DIR("B")=IBSMN,DIR("T")=DTIME,DIR("?")="^S IBOFF=21 D HELP^IBJDF4H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSMX=+Y W " ",IBSMX," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
;
AMT ; - Print receivables with a minimum balance.
S DIR(0)="Y",DIR("B")="NO" W !
S DIR("A")="Print receivables with a minimum balance"
S DIR("T")=DTIME,DIR("?")="^S IBOFF=26 D HELP^IBJDF4H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSAM EXCEL
;
AMT1 ; - Determine the minimum balance amount.
S DIR(0)="NA^1:9999999"
S DIR("A")="Enter the minimum balance amount of the receivable: "
S DIR("T")=DTIME,DIR("?")="^S IBOFF=33 D HELP^IBJDF4H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
EXCEL ; - Determine whether to gather data for Excel report.
S IBEXCEL=$$EXCEL^IBJD() G ENQ:IBEXCEL="^"
I IBEXCEL S IBSH=1,IBSH1="M" G RC
;
BCH ; - Determine whether to include the bill comment history.
S DIR(0)="Y",DIR("B")="NO" W !
S DIR("A")="Include the bill comment history with each receivable"
S DIR("T")=DTIME,DIR("?")="^S IBOFF=38 D HELP^IBJDF4H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSH=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSH RC
;
S DIR(0)="SA^A:ALL;M:MOST RECENT"
S DIR("A")="Print (A)LL comments or the (M)OST RECENT comment: "
S DIR("B")="ALL",DIR("T")=DTIME,DIR("?")="^S IBOFF=47 D HELP^IBJDF4H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSH1=Y K DIROUT,DTOUT,DUOUT,DIRUT G:IBSH1="A" RC
;
S DIR(0)="NAO^1:999"
S DIR("A")="Minimum age of most recent bill comment (optional): "
S DIR("T")=DTIME,DIR("?")="^S IBOFF=54 D HELP^IBJDF4H"
D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSH2=+Y W:IBSH2 " days" K DIROUT,DTOUT,DUOUT
;
RC ; - Include receivables referred to Regional Counsel?
S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W !
S DIR("A")="Include ARs referred to Regional Counsel"
S DIR("?")="^S IBOFF=61 D HELP^IBJDF4H"
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
S IBSRC=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
DEV ; - Select a device.
I '$G(IBEXCEL) D
. W !!,"Note: This report will search through all "
. W $S(IBSTA="A":"active",IBSTA="S":"suspended",1:"active & suspended")," receivables."
. W !?6,"It is recommended that you queue it to run after normal business hours."
;
I $G(IBEXCEL) D EXMSG^IBJD
;
W ! S %ZIS="QM" D ^%ZIS G:POP ENQ
I $D(IO("Q")) D G ENQ
.S ZTRTN="DQ^IBJDF4",ZTDESC="IB - FIRST PARTY FOLLOW-UP REPORT"
.S ZTSAVE("IB*")="" D ^%ZTLOAD
.I $G(ZTSK) W !!,"This job has been queued. The task no. is ",ZTSK,"."
.E W !!,"Unable to queue this job."
.K ZTSK,IO("Q") D HOME^%ZIS
;
U IO
;
; If called by the Extraction Module, change extract status for the 5
; reports: Emergency/Humanitarian, Ineligible receivables, C-Means Test,
; RX Copay/SC VET and RX Copay/NSC VET
DQ I $G(IBXTRACT) F I=12:1:16 D E^IBJDE(I,1)
;
D ST^IBJDF41 ; Compile and print the report.
;
ENQ K IBSEL,IBSN,IBSNF,IBSNL,IBOFF,IBSNA,IBSH,IBSH1,IBSH2,IBSAM,IBSRC,IBTEXT
K IBI,IBOPT,IBPRT,IBSTA,IBEXCEL,IBRPT,IBSMN,IBSMX,IBSELST,IBSUSTYP,POP,DIROUT,DTOUT,DUOUT
K DIRUT,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X,Y
Q
;
MLTP0(PRPT,OPT,ALL) ; Function for multiple value selection
; Input: PRPT - String to be prompted to the user, before listing options
; OPT - Array containing the possible entries (indexed by code)
; Obs: Code must be sequential starting with 0
; ALL - Flag indicating if the last option is ALL OF THE ABOVE
;
; Output: MLTP - User selection, i.e. ",1,2,3," or "1," or NULL (nothing
; was selected)
;
N A,DIR,DIRUT,DTOUT,DUOUT,DIROUT,I,IX,LST,MLTP
;
PRPT S MLTP="",ALL=+$G(ALL)
S LST=$O(OPT(""),-1)
S DIR(0)="LO^0:"_LST_"^K:+$P(X,""-"",2)>"_LST_" X"
S DIR("A",1)=$G(PRPT),DIR("A",2)=""
S A="",IX=3
F S A=$O(OPT(A)) Q:A="" D
. S DIR("A",IX)=" "_A_" - "_$G(OPT(A)),IX=IX+1
S DIR("A",IX)="",DIR("A")="Select",DIR("B")=LST,DIR("T")=DTIME W !
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G QT
S MLTP=Y K DIROUT,DTOUT,DUOUT,DIRUT
;
I ALL,MLTP[LST S MLTP=LST_","
;
S DIR(0)="Y",DIR("A",1)="You have selected",DIR("A",2)=""
S A="",IX=3
F I=1:1:($L(MLTP,",")-1) D
. S DIR("A",IX)=" "_$P(MLTP,",",I)_" - "_$G(OPT($P(MLTP,",",I)))
. S IX=IX+1
S DIR("A",IX)=""
S DIR("A")="Are you sure",DIR("B")="NO",DIR("T")=DTIME W !
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) S MLTP="" G QT
K DIROUT,DTOUT,DUOUT,DIRUT I 'Y K DIR G PRPT
;
I ALL,MLTP[LST D
. S MLTP="" F I=(LST-1):-1:0 S MLTP=I_","_MLTP
;
QT I MLTP'="" S MLTP=","_MLTP
Q MLTP
;
DS ; Print a (S)ummary,(O)verall Summary or (D)etail Report?
S DIR(0)="SA^S:SUMMARY;D:DETAILED;O:OVERALL SUMMARY;"
S DIR("A")="Do you wish to print a (S)ummary, (O)verall Summary or (D)etailed Report? "
S DIR("?")="^D HDS^IBJDF4" ; IB*2.0*705
W ! D ^DIR K DIR S IBRPT=Y
Q
;
HDS ; Help for Summary/Detail prompt. ; IB*2.0*705
W !,"Please enter 'S' for 'Summary', 'O' for 'Overall Summary' or 'D' for a Detailed Report."
W !,"Note that if you select the Detailed report, Summary and Overall Summary will also print."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF4 8151 printed Dec 13, 2024@02:22:48 Page 2
IBJDF4 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT ;15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,204,220,568,618,705,739**;21-MAR-94;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to 433.001 in ICR #7321
+5 ;
EN ; - Option entry point.
+1 SET IBEXCEL=0
+2 ; get suspension types from file 433.001 IB*2.0*705
+3 NEW I,LAST,SUSCODE,SUSIEN,X
+4 KILL IBSUS
+5 SET SUSCODE=""
FOR
SET SUSCODE=$ORDER(^PRCA(433.001,"B",SUSCODE))
if SUSCODE=""
QUIT
Begin DoDot:1
+6 SET SUSIEN=$ORDER(^PRCA(433.001,"B",SUSCODE,""))
if 'SUSIEN
QUIT
+7 SET IBSUS(SUSCODE)=$$GET1^DIQ(433.001,SUSIEN_",",.02)
+8 QUIT
End DoDot:1
+9 SET LAST=$ORDER(IBSUS(""),-1)
SET IBSUS(LAST+1)="NONE"
+10 SET LAST=LAST+2
SET IBSUS(LAST)="ALL OF THE ABOVE"
+11 ;
+12 ; - Select AR categories to print.
+13 SET IBPRT="Choose which type of receivables to print:"
+14 KILL IBOPT
+15 SET IBOPT(1)="EMERGENCY/HUMANITARIAN"
+16 SET IBOPT(2)="INELIGIBLE"
+17 SET IBOPT(3)="C-MEANS TEST & RX COPAY"
+18 SET IBOPT(4)="LONG TERM CARE COPAY"
+19 SET IBOPT(5)="COMMUNITY CARE COPAY"
+20 SET IBOPT(6)="ALL OF THE ABOVE"
+21 SET IBSEL=$$MLTP^IBJD(IBPRT,.IBOPT,1)
IF 'IBSEL
GOTO ENQ
+22 ;
STA ; - Choose bill status.
+1 WRITE !!,"Run report for (A)CTIVE ARs, (S)USPENDED ARs, or (B)OTH: B// "
+2 READ X:DTIME
if '$TEST!(X["^")
GOTO ENQ
if X=""
SET X="B"
SET X=$EXTRACT(X)
+3 IF "AaBbSs"'[X
SET IBOFF=1
DO HELP^IBJDF4H
GOTO STA
+4 SET IBSTA=$SELECT("Aa"[X:"A","Ss"[X:"S",1:"B")
+5 WRITE " ",$SELECT(IBSTA="A":"ACTIVE",IBSTA="S":"SUSPENDED",1:"BOTH")
+6 ;
SUSTYP ;If SUSPENDED is chosen, prompt for which suspended bills to display IB*2.0*568/DRF
+1 IF IBSTA="S"
Begin DoDot:1
+2 SET IBPRT="Choose which suspended types to print:"
+3 SET IBSELST=$$MLTP0(IBPRT,.IBSUS,1)
End DoDot:1
+4 IF IBSTA="S"
IF IBSELST=""
GOTO ENQ
+5 ;
+6 ; - Select a detailed or summary report.
+7 DO DS
if IBRPT["^"
GOTO ENQ
+8 IF IBRPT="S"!(IBRPT="O")
Begin DoDot:1
+9 SET IBSN="N"
SET IBSNA="ALL"
SET IBSNF=""
SET IBSNL="zzzzz"
SET IBSMN="A"
End DoDot:1
GOTO RC
+10 ;
+11 ; - Determine sorting (By name or Last 4 SSN)
+12 ;IB*2.0*739 force sorting by NAME
SET IBSN="N"
+13 ;
+14 ; - Determine the range
+15 SET X=$$INTV^IBJD("PATIENT "_$SELECT(IBSN="N":"NAME",1:"LAST 4"))
if X="^"
GOTO ENQ
+16 SET IBSNF=$PIECE(X,"^",1)
SET IBSNL=$PIECE(X,"^",2)
SET IBSNA=$PIECE(X,"^",3)
+17 ;
AGE ; - Determine if the active receivable must be within an age range.
+1 WRITE !!,"Include (A)LL ",$SELECT(IBSTA="A":"active ",IBSTA="S":"suspended ",1:""),"ARs or those within an AGE (R)ANGE: ALL// "
+2 READ X:DTIME
if '$TEST!(X["^")
GOTO ENQ
if X=""
SET X="A"
SET X=$EXTRACT(X)
+3 IF "ARar"'[X
SET IBOFF=9
DO HELP^IBJDF4H
GOTO AGE
+4 SET IBSMN=$SELECT("Rr"[X:"R",1:"A")
WRITE " ",$SELECT(IBSMN="R":"RANGE",1:"ALL")
+5 IF IBSMN="A"
GOTO AMT
+6 ;
+7 ; - Determine the active receivable age range.
+8 WRITE !,"EXAMPLE Range: 31-60 days"
+9 SET DIR(0)="NA^1:99999"
+10 SET DIR("A")="Enter the minimum age of the receivable: "
+11 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=16 D HELP^IBJDF4H"
+12 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+13 SET IBSMN=+Y
WRITE " ",IBSMN," DAYS"
KILL DIROUT,DTOUT,DUOUT,DIRUT
+14 ;
+15 SET DIR(0)="NA^"_IBSMN_":99999"
+16 SET DIR("A")="Enter the maximum age of the receivable: "
+17 SET DIR("B")=IBSMN
SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=21 D HELP^IBJDF4H"
+18 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+19 SET IBSMX=+Y
WRITE " ",IBSMX," DAYS"
KILL DIROUT,DTOUT,DUOUT,DIRUT
+20 ;
AMT ; - Print receivables with a minimum balance.
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
WRITE !
+2 SET DIR("A")="Print receivables with a minimum balance"
+3 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=26 D HELP^IBJDF4H"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+5 SET IBSAM=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
if 'IBSAM
GOTO EXCEL
+6 ;
AMT1 ; - Determine the minimum balance amount.
+1 SET DIR(0)="NA^1:9999999"
+2 SET DIR("A")="Enter the minimum balance amount of the receivable: "
+3 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=33 D HELP^IBJDF4H"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+5 SET IBSAM=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+6 ;
EXCEL ; - Determine whether to gather data for Excel report.
+1 SET IBEXCEL=$$EXCEL^IBJD()
if IBEXCEL="^"
GOTO ENQ
+2 IF IBEXCEL
SET IBSH=1
SET IBSH1="M"
GOTO RC
+3 ;
BCH ; - Determine whether to include the bill comment history.
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
WRITE !
+2 SET DIR("A")="Include the bill comment history with each receivable"
+3 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=38 D HELP^IBJDF4H"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+5 SET IBSH=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
if 'IBSH
GOTO RC
+6 ;
+7 SET DIR(0)="SA^A:ALL;M:MOST RECENT"
+8 SET DIR("A")="Print (A)LL comments or the (M)OST RECENT comment: "
+9 SET DIR("B")="ALL"
SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=47 D HELP^IBJDF4H"
+10 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+11 SET IBSH1=Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
if IBSH1="A"
GOTO RC
+12 ;
+13 SET DIR(0)="NAO^1:999"
+14 SET DIR("A")="Minimum age of most recent bill comment (optional): "
+15 SET DIR("T")=DTIME
SET DIR("?")="^S IBOFF=54 D HELP^IBJDF4H"
+16 DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+17 SET IBSH2=+Y
if IBSH2
WRITE " days"
KILL DIROUT,DTOUT,DUOUT
+18 ;
RC ; - Include receivables referred to Regional Counsel?
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("T")=DTIME
WRITE !
+2 SET DIR("A")="Include ARs referred to Regional Counsel"
+3 SET DIR("?")="^S IBOFF=61 D HELP^IBJDF4H"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO ENQ
+5 SET IBSRC=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+6 ;
DEV ; - Select a device.
+1 IF '$GET(IBEXCEL)
Begin DoDot:1
+2 WRITE !!,"Note: This report will search through all "
+3 WRITE $SELECT(IBSTA="A":"active",IBSTA="S":"suspended",1:"active & suspended")," receivables."
+4 WRITE !?6,"It is recommended that you queue it to run after normal business hours."
End DoDot:1
+5 ;
+6 IF $GET(IBEXCEL)
DO EXMSG^IBJD
+7 ;
+8 WRITE !
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTRTN="DQ^IBJDF4"
SET ZTDESC="IB - FIRST PARTY FOLLOW-UP REPORT"
+11 SET ZTSAVE("IB*")=""
DO ^%ZTLOAD
+12 IF $GET(ZTSK)
WRITE !!,"This job has been queued. The task no. is ",ZTSK,"."
+13 IF '$TEST
WRITE !!,"Unable to queue this job."
+14 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+15 ;
+16 USE IO
+17 ;
+18 ; If called by the Extraction Module, change extract status for the 5
+19 ; reports: Emergency/Humanitarian, Ineligible receivables, C-Means Test,
+20 ; RX Copay/SC VET and RX Copay/NSC VET
DQ IF $GET(IBXTRACT)
FOR I=12:1:16
DO E^IBJDE(I,1)
+1 ;
+2 ; Compile and print the report.
DO ST^IBJDF41
+3 ;
ENQ KILL IBSEL,IBSN,IBSNF,IBSNL,IBOFF,IBSNA,IBSH,IBSH1,IBSH2,IBSAM,IBSRC,IBTEXT
+1 KILL IBI,IBOPT,IBPRT,IBSTA,IBEXCEL,IBRPT,IBSMN,IBSMX,IBSELST,IBSUSTYP,POP,DIROUT,DTOUT,DUOUT
+2 KILL DIRUT,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X,Y
+3 QUIT
+4 ;
MLTP0(PRPT,OPT,ALL) ; Function for multiple value selection
+1 ; Input: PRPT - String to be prompted to the user, before listing options
+2 ; OPT - Array containing the possible entries (indexed by code)
+3 ; Obs: Code must be sequential starting with 0
+4 ; ALL - Flag indicating if the last option is ALL OF THE ABOVE
+5 ;
+6 ; Output: MLTP - User selection, i.e. ",1,2,3," or "1," or NULL (nothing
+7 ; was selected)
+8 ;
+9 NEW A,DIR,DIRUT,DTOUT,DUOUT,DIROUT,I,IX,LST,MLTP
+10 ;
PRPT SET MLTP=""
SET ALL=+$GET(ALL)
+1 SET LST=$ORDER(OPT(""),-1)
+2 SET DIR(0)="LO^0:"_LST_"^K:+$P(X,""-"",2)>"_LST_" X"
+3 SET DIR("A",1)=$GET(PRPT)
SET DIR("A",2)=""
+4 SET A=""
SET IX=3
+5 FOR
SET A=$ORDER(OPT(A))
if A=""
QUIT
Begin DoDot:1
+6 SET DIR("A",IX)=" "_A_" - "_$GET(OPT(A))
SET IX=IX+1
End DoDot:1
+7 SET DIR("A",IX)=""
SET DIR("A")="Select"
SET DIR("B")=LST
SET DIR("T")=DTIME
WRITE !
+8 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO QT
+9 SET MLTP=Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+10 ;
+11 IF ALL
IF MLTP[LST
SET MLTP=LST_","
+12 ;
+13 SET DIR(0)="Y"
SET DIR("A",1)="You have selected"
SET DIR("A",2)=""
+14 SET A=""
SET IX=3
+15 FOR I=1:1:($LENGTH(MLTP,",")-1)
Begin DoDot:1
+16 SET DIR("A",IX)=" "_$PIECE(MLTP,",",I)_" - "_$GET(OPT($PIECE(MLTP,",",I)))
+17 SET IX=IX+1
End DoDot:1
+18 SET DIR("A",IX)=""
+19 SET DIR("A")="Are you sure"
SET DIR("B")="NO"
SET DIR("T")=DTIME
WRITE !
+20 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET MLTP=""
GOTO QT
+21 KILL DIROUT,DTOUT,DUOUT,DIRUT
IF 'Y
KILL DIR
GOTO PRPT
+22 ;
+23 IF ALL
IF MLTP[LST
Begin DoDot:1
+24 SET MLTP=""
FOR I=(LST-1):-1:0
SET MLTP=I_","_MLTP
End DoDot:1
+25 ;
QT IF MLTP'=""
SET MLTP=","_MLTP
+1 QUIT MLTP
+2 ;
DS ; Print a (S)ummary,(O)verall Summary or (D)etail Report?
+1 SET DIR(0)="SA^S:SUMMARY;D:DETAILED;O:OVERALL SUMMARY;"
+2 SET DIR("A")="Do you wish to print a (S)ummary, (O)verall Summary or (D)etailed Report? "
+3 ; IB*2.0*705
SET DIR("?")="^D HDS^IBJDF4"
+4 WRITE !
DO ^DIR
KILL DIR
SET IBRPT=Y
+5 QUIT
+6 ;
HDS ; Help for Summary/Detail prompt. ; IB*2.0*705
+1 WRITE !,"Please enter 'S' for 'Summary', 'O' for 'Overall Summary' or 'D' for a Detailed Report."
+2 WRITE !,"Note that if you select the Detailed report, Summary and Overall Summary will also print."
+3 QUIT
