IBOTR1 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - USER INTERFACE ;5-JUN-91
;;2.0;INTEGRATED BILLING;**21,42,72,100,118,128,528,743,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCROTR1
;
OUTPT W !!,"Select (I)NPATIENT, (O)UTPATIENT, or (B)OTH bill records: BOTH// "
R X:DTIME G:'$T!(X["^") END S:X="" X="B" S X=$E(X)
I "BIObio"'[X S IBOFF=1 D HELP^IBOTR11 G OUTPT
W " ",$S("Ii"[X:"INPATIENT","Oo"[X:"OUTPATIENT",1:"BOTH")
S (IBBRT,IBBRTY)=$S("Ii"[X:"I","Oo"[X:"O",1:"A") I "Bb"'[X G ARST
;
REPTY W !,"Print (C)OMBINED or (S)EPARATE reports: COMBINED// "
R X:DTIME G:'$T!(X["^") END S:X="" X="C" S X=$E(X)
I "CScs"'[X S IBOFF=7 D HELP^IBOTR11 G REPTY
W " ",$S("Cc"[X:"COMBINED",1:"SEPARATE")
S IBBRN=$S("Cc"[X:"C",1:"S")
;
ARST W !,"Select (O)PEN, (C)LOSED, or (B)OTH types of bills: BOTH// "
R X:DTIME G:'$T!(X["^") END S:X="" X="B" S X=$E(X)
I "BCObco"'[X S IBOFF=14 D HELP^IBOTR11 G ARST
W " ",$S("Oo"[X:"OPEN","Cc"[X:"CLOSED",1:"BOTH")
S IBARST=$S("Oo"[X:"O","Cc"[X:"C",1:"A")
;
CANC I $G(IBAF)=16 G QDATE ; Skip if CANCEL BILL? field was selected.
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Do you want to include cancelled bills"
S (DIR("?"),DIR("??"))="^S IBOFF=20 D HELP^IBOTR11"
D ^DIR K DIR S IBCANC=+Y I $D(DIRUT)!$D(DTOUT)!$D(DUOUT) G END
;
QDATE S DIR(0)="SA^1:DATE BILL PRINTED;2:TREATMENT DATE"
S DIR("A")="Print report by 1-DATE BILL PRINTED or 2-TREATMENT DATE: "
;IB*752/TAZ - Removed the DIR("T") variable so that DIR would honor DTIME for the timeout.
;S DIR("B")="1",DIR("T")=20,DIR("?")="^S IBOFF=25 D HELP^IBOTR11"
S DIR("B")="1",DIR("?")="^S IBOFF=25 D HELP^IBOTR11"
W ! D ^DIR K DIR G:Y=""!(X="^") END S IBDF=Y,IBDFN=Y(0)
BEGDT S %DT="AEPX",%DT("A")=" Start with "_IBDFN_": "
D ^%DT K %DT G:Y<0 END S IBBDT=Y
S %DT="AEPX",%DT("A")=" Go to "_IBDFN_": "
D ^%DT K %DT G:Y<0 END S IBEDT=Y
I Y<IBBDT W *7,!!?3,"The END DATE must follow the BEGIN DATE.",! G BEGDT
;
PRINT W !!,"Print (M)AIN REPORT, (S)UMMARY, or (G)RAND TOTALS: M// "
R X:DTIME G:'$T!(X["^") END S:X="" X="M" S X=$E(X)
I "GMSgms"'[X S IBOFF=30 D HELP^IBOTR11 G PRINT
W " ",$S("Mm"[X:"MAIN REPORT","Ss"[X:"SUMMARY",1:"GRAND TOTALS")
S IBPRNT=$S("Mm"[X:"M","Ss"[X:"S",1:"G")
;
INS W !,"Run ",$S("MS"[IBPRNT:"report",1:"totals")
W " for (S)PECIFIC insurance companies or a (R)ANGE: RANGE// "
R X:DTIME G:'$T!(X["^") END S:X="" X="R" S X=$E(X)
I "RSrs"'[X S IBOFF=38 D HELP^IBOTR11 G INS
W " ",$S("Ss"[X:"SPECIFIC",1:"RANGE") G:"Rr"[X INSO1 K IBICPT
;IB*752/DTG - change to be case insensitive
INSO ;S DIC="^DIC(36,",DIC(0)="AEQMZ",DIC("S")="I '$G(^(5))"
;S DIC("A")=" Select "_$S($G(IBICPT):"another ",1:"")_"INSURANCE CO.: "
;D ^DIC K DIC I Y'>0 G END:'$G(IBICPT),INSO3
;I $D(IBICPT(+Y)) D G INSO
;.W !!?3,"Already selected. Choose another insurance company.",!,*7
;S IBICPT(+Y)="",IBICPT=$G(IBICPT)+1 G INSO
;
S IBSCR="I '$G(^DIC(36,+Y,5))"
D INSOCAS^IBCNINSC(.IBRET,0,,.IBSCR) ;IB*752 - use new lookup
G END:'$G(IBRET)
S IBI=0 F S IBI=$O(IBRET(IBI)) Q:'IBI S IBICPT(IBI)="",IBICPT=$G(IBICPT)+1
K IBRET
G INSO3
;
; IB*752/DTG end - change from standard DIC call for upper/lower
;
;IB*743/TAZ - Updated INSO1 to FileMan Read and to accept NULL to mean beginning of list.
INSO1 ;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
W !!,"Enter Start With value or Press <ENTER> to start at the beginning of the list.",!
S DIR(0)="FO"
S DIR("A")="Start with INSURANCE COMPANY"
S DIR("?")="^S IBOFF=43 D HELP^IBOTR11"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) G END
S IBICF=Y
; IB*752/DTG change user's response to upper case
S IBICFU=IBICF I (('IBICF)&(IBICF'="@")&(IBICF'="")) S IBICFU=$$UP^XLFSTR(IBICF)
;
;IB*743/TAZ - Updated FD2 to FileMan Read and to accept NULL to mean end of list.
INSO2 ;
W !!,"Enter Go To value or Press <ENTER> to finish at the end of the list.",!
S DIR(0)="FO"
S DIR("A")="Go to INSURANCE COMPANY"
S DIR("?")="^S IBOFF=49 D HELP^IBOTR11"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) G END
;IB*752/DTG change user's response to upper case
;I Y="" S IBICL="zzzzz" S:IBICF="" IBIC="ALL" G INSO3
;I Y="@",IBICF="@" S IBICL="@",IBIC="NULL" G INSO3
I Y="" S IBICL="zzzzz",IBICLU=IBICL S:IBICF="" IBIC="ALL" G INSO3
I Y="@",IBICF="@" S IBICL="@",IBICLU=IBICL,IBIC="NULL" G INSO3
;
I (('Y)&(Y'="@")&(Y'="zzzzz")) S Y=$$UP^XLFSTR(Y) ; IB*752/DTG
;
;I IBICF'="@",IBICF]Y D G INSO1
I IBICFU'="@",IBICFU]Y D G INSO1
.W *7,!!?3,"The Go To INSURANCE COMPANY must follow the Start With INSURANCE COMPANY.",!
;S IBICL=Y
S (IBICL,IBICLU)=Y
;
INSO3 I IBPRNT="G" S IBSORT="I" S:$G(IBICPT)!($G(IBIC)'="ALL") IBG=1 G EXRC
I $G(IBICPT)=1 S IBSORT="I" G EXRC
W !,"Sort by AMOUNT (O)WED, AMOUNT (P)AID, or (I)NSURANCE CO.: I// "
R X:DTIME G:'$T!(X["^") END S:X="" X="I" S X=$E(X)
I "IOPiop"'[X S IBOFF=56 D HELP^IBOTR11 G INSO3
W " ",$S("Oo"[X:"AMOUNT OWED","Pp"[X:"AMOUNT PAID",1:"INSURANCE CO.")
S IBSORT=$S("Oo"[X:"O","Pp"[X:"P",1:"I")
;
EXRC S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Do you want to include receivables referred to Reg. Counsel"
S DIR("?")="^S IBOFF=66 D HELP^IBOTR11"
W ! D ^DIR K DIR S IBINRC=+Y I $D(DIRUT)!$D(DTOUT)!$D(DUOUT) G END
;
;Select report type
K IBOUT
S IBOUT=$$OUT
I IBOUT["^" G END ;IB*752/DTG - quit if upcaret
;
DEV I IBOUT="R" W !!,"You will need a 132 column printer for this report!"
I IBOUT="E" W !!,"To avoid undesired wrapping, please enter ""0;256;999"" at the 'DEVICE:' prompt.",!
N %ZIS,ZTRTN,ZTDESC,ZTSAVE,ZTSK
S %ZIS="QM" D ^%ZIS G:POP END
I $D(IO("Q")) D G END
.S ZTRTN="^IBOTR2",ZTDESC="INSURANCE PAYMENT TREND REPORT"
.F X="IB*","IBOUT","VAUTD","VAUTD(" S ZTSAVE(X)=""
.D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
.K ZTSK,IO("Q") D HOME^%ZIS
U IO
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOTR1" D T1^%ZOSV ;stop rt clock
D ^IBOTR2 ; Compile and print report.
;
END K DIRUT,DTOUT,DUOUT,DIROUT
Q
;
OUT() ; Prompt to allow users to select output format
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
W !
S DIR(0)="SA^E:Excel;R:Report"
S DIR("A")="(E)xcel Format or (R)eport Format: "
S DIR("B")="Report"
D ^DIR I $D(DIRUT)!($E(Y)=U) S STOP=1 Q U ;IB*752/DTG send upcaret if stop
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOTR1 6401 printed Nov 22, 2024@17:36:13 Page 2
IBOTR1 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - USER INTERFACE ;5-JUN-91
+1 ;;2.0;INTEGRATED BILLING;**21,42,72,100,118,128,528,743,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCROTR1
+5 ;
OUTPT WRITE !!,"Select (I)NPATIENT, (O)UTPATIENT, or (B)OTH bill records: BOTH// "
+1 READ X:DTIME
if '$TEST!(X["^")
GOTO END
if X=""
SET X="B"
SET X=$EXTRACT(X)
+2 IF "BIObio"'[X
SET IBOFF=1
DO HELP^IBOTR11
GOTO OUTPT
+3 WRITE " ",$SELECT("Ii"[X:"INPATIENT","Oo"[X:"OUTPATIENT",1:"BOTH")
+4 SET (IBBRT,IBBRTY)=$SELECT("Ii"[X:"I","Oo"[X:"O",1:"A")
IF "Bb"'[X
GOTO ARST
+5 ;
REPTY WRITE !,"Print (C)OMBINED or (S)EPARATE reports: COMBINED// "
+1 READ X:DTIME
if '$TEST!(X["^")
GOTO END
if X=""
SET X="C"
SET X=$EXTRACT(X)
+2 IF "CScs"'[X
SET IBOFF=7
DO HELP^IBOTR11
GOTO REPTY
+3 WRITE " ",$SELECT("Cc"[X:"COMBINED",1:"SEPARATE")
+4 SET IBBRN=$SELECT("Cc"[X:"C",1:"S")
+5 ;
ARST WRITE !,"Select (O)PEN, (C)LOSED, or (B)OTH types of bills: BOTH// "
+1 READ X:DTIME
if '$TEST!(X["^")
GOTO END
if X=""
SET X="B"
SET X=$EXTRACT(X)
+2 IF "BCObco"'[X
SET IBOFF=14
DO HELP^IBOTR11
GOTO ARST
+3 WRITE " ",$SELECT("Oo"[X:"OPEN","Cc"[X:"CLOSED",1:"BOTH")
+4 SET IBARST=$SELECT("Oo"[X:"O","Cc"[X:"C",1:"A")
+5 ;
CANC ; Skip if CANCEL BILL? field was selected.
IF $GET(IBAF)=16
GOTO QDATE
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
+2 SET DIR("A")="Do you want to include cancelled bills"
+3 SET (DIR("?"),DIR("??"))="^S IBOFF=20 D HELP^IBOTR11"
+4 DO ^DIR
KILL DIR
SET IBCANC=+Y
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO END
+5 ;
QDATE SET DIR(0)="SA^1:DATE BILL PRINTED;2:TREATMENT DATE"
+1 SET DIR("A")="Print report by 1-DATE BILL PRINTED or 2-TREATMENT DATE: "
+2 ;IB*752/TAZ - Removed the DIR("T") variable so that DIR would honor DTIME for the timeout.
+3 ;S DIR("B")="1",DIR("T")=20,DIR("?")="^S IBOFF=25 D HELP^IBOTR11"
+4 SET DIR("B")="1"
SET DIR("?")="^S IBOFF=25 D HELP^IBOTR11"
+5 WRITE !
DO ^DIR
KILL DIR
if Y=""!(X="^")
GOTO END
SET IBDF=Y
SET IBDFN=Y(0)
BEGDT SET %DT="AEPX"
SET %DT("A")=" Start with "_IBDFN_": "
+1 DO ^%DT
KILL %DT
if Y<0
GOTO END
SET IBBDT=Y
+2 SET %DT="AEPX"
SET %DT("A")=" Go to "_IBDFN_": "
+3 DO ^%DT
KILL %DT
if Y<0
GOTO END
SET IBEDT=Y
+4 IF Y<IBBDT
WRITE *7,!!?3,"The END DATE must follow the BEGIN DATE.",!
GOTO BEGDT
+5 ;
PRINT WRITE !!,"Print (M)AIN REPORT, (S)UMMARY, or (G)RAND TOTALS: M// "
+1 READ X:DTIME
if '$TEST!(X["^")
GOTO END
if X=""
SET X="M"
SET X=$EXTRACT(X)
+2 IF "GMSgms"'[X
SET IBOFF=30
DO HELP^IBOTR11
GOTO PRINT
+3 WRITE " ",$SELECT("Mm"[X:"MAIN REPORT","Ss"[X:"SUMMARY",1:"GRAND TOTALS")
+4 SET IBPRNT=$SELECT("Mm"[X:"M","Ss"[X:"S",1:"G")
+5 ;
INS WRITE !,"Run ",$SELECT("MS"[IBPRNT:"report",1:"totals")
+1 WRITE " for (S)PECIFIC insurance companies or a (R)ANGE: RANGE// "
+2 READ X:DTIME
if '$TEST!(X["^")
GOTO END
if X=""
SET X="R"
SET X=$EXTRACT(X)
+3 IF "RSrs"'[X
SET IBOFF=38
DO HELP^IBOTR11
GOTO INS
+4 WRITE " ",$SELECT("Ss"[X:"SPECIFIC",1:"RANGE")
if "Rr"[X
GOTO INSO1
KILL IBICPT
+5 ;IB*752/DTG - change to be case insensitive
INSO ;S DIC="^DIC(36,",DIC(0)="AEQMZ",DIC("S")="I '$G(^(5))"
+1 ;S DIC("A")=" Select "_$S($G(IBICPT):"another ",1:"")_"INSURANCE CO.: "
+2 ;D ^DIC K DIC I Y'>0 G END:'$G(IBICPT),INSO3
+3 ;I $D(IBICPT(+Y)) D G INSO
+4 ;.W !!?3,"Already selected. Choose another insurance company.",!,*7
+5 ;S IBICPT(+Y)="",IBICPT=$G(IBICPT)+1 G INSO
+6 ;
+7 SET IBSCR="I '$G(^DIC(36,+Y,5))"
+8 ;IB*752 - use new lookup
DO INSOCAS^IBCNINSC(.IBRET,0,,.IBSCR)
+9 if '$GET(IBRET)
GOTO END
+10 SET IBI=0
FOR
SET IBI=$ORDER(IBRET(IBI))
if 'IBI
QUIT
SET IBICPT(IBI)=""
SET IBICPT=$GET(IBICPT)+1
+11 KILL IBRET
+12 GOTO INSO3
+13 ;
+14 ; IB*752/DTG end - change from standard DIC call for upper/lower
+15 ;
+16 ;IB*743/TAZ - Updated INSO1 to FileMan Read and to accept NULL to mean beginning of list.
INSO1 ;
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 WRITE !!,"Enter Start With value or Press <ENTER> to start at the beginning of the list.",!
+3 SET DIR(0)="FO"
+4 SET DIR("A")="Start with INSURANCE COMPANY"
+5 SET DIR("?")="^S IBOFF=43 D HELP^IBOTR11"
+6 DO ^DIR
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO END
+8 SET IBICF=Y
+9 ; IB*752/DTG change user's response to upper case
+10 SET IBICFU=IBICF
IF (('IBICF)&(IBICF'="@")&(IBICF'=""))
SET IBICFU=$$UP^XLFSTR(IBICF)
+11 ;
+12 ;IB*743/TAZ - Updated FD2 to FileMan Read and to accept NULL to mean end of list.
INSO2 ;
+1 WRITE !!,"Enter Go To value or Press <ENTER> to finish at the end of the list.",!
+2 SET DIR(0)="FO"
+3 SET DIR("A")="Go to INSURANCE COMPANY"
+4 SET DIR("?")="^S IBOFF=49 D HELP^IBOTR11"
+5 DO ^DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO END
+7 ;IB*752/DTG change user's response to upper case
+8 ;I Y="" S IBICL="zzzzz" S:IBICF="" IBIC="ALL" G INSO3
+9 ;I Y="@",IBICF="@" S IBICL="@",IBIC="NULL" G INSO3
+10 IF Y=""
SET IBICL="zzzzz"
SET IBICLU=IBICL
if IBICF=""
SET IBIC="ALL"
GOTO INSO3
+11 IF Y="@"
IF IBICF="@"
SET IBICL="@"
SET IBICLU=IBICL
SET IBIC="NULL"
GOTO INSO3
+12 ;
+13 ; IB*752/DTG
IF (('Y)&(Y'="@")&(Y'="zzzzz"))
SET Y=$$UP^XLFSTR(Y)
+14 ;
+15 ;I IBICF'="@",IBICF]Y D G INSO1
+16 IF IBICFU'="@"
IF IBICFU]Y
Begin DoDot:1
+17 WRITE *7,!!?3,"The Go To INSURANCE COMPANY must follow the Start With INSURANCE COMPANY.",!
End DoDot:1
GOTO INSO1
+18 ;S IBICL=Y
+19 SET (IBICL,IBICLU)=Y
+20 ;
INSO3 IF IBPRNT="G"
SET IBSORT="I"
if $GET(IBICPT)!($GET(IBIC)'="ALL")
SET IBG=1
GOTO EXRC
+1 IF $GET(IBICPT)=1
SET IBSORT="I"
GOTO EXRC
+2 WRITE !,"Sort by AMOUNT (O)WED, AMOUNT (P)AID, or (I)NSURANCE CO.: I// "
+3 READ X:DTIME
if '$TEST!(X["^")
GOTO END
if X=""
SET X="I"
SET X=$EXTRACT(X)
+4 IF "IOPiop"'[X
SET IBOFF=56
DO HELP^IBOTR11
GOTO INSO3
+5 WRITE " ",$SELECT("Oo"[X:"AMOUNT OWED","Pp"[X:"AMOUNT PAID",1:"INSURANCE CO.")
+6 SET IBSORT=$SELECT("Oo"[X:"O","Pp"[X:"P",1:"I")
+7 ;
EXRC SET DIR(0)="Y"
SET DIR("B")="NO"
+1 SET DIR("A")="Do you want to include receivables referred to Reg. Counsel"
+2 SET DIR("?")="^S IBOFF=66 D HELP^IBOTR11"
+3 WRITE !
DO ^DIR
KILL DIR
SET IBINRC=+Y
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO END
+4 ;
+5 ;Select report type
+6 KILL IBOUT
+7 SET IBOUT=$$OUT
+8 ;IB*752/DTG - quit if upcaret
IF IBOUT["^"
GOTO END
+9 ;
DEV IF IBOUT="R"
WRITE !!,"You will need a 132 column printer for this report!"
+1 IF IBOUT="E"
WRITE !!,"To avoid undesired wrapping, please enter ""0;256;999"" at the 'DEVICE:' prompt.",!
+2 NEW %ZIS,ZTRTN,ZTDESC,ZTSAVE,ZTSK
+3 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="^IBOTR2"
SET ZTDESC="INSURANCE PAYMENT TREND REPORT"
+6 FOR X="IB*","IBOUT","VAUTD","VAUTD("
SET ZTSAVE(X)=""
+7 DO ^%ZTLOAD
WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
+8 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO END
+9 USE IO
+10 ;***
+11 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOTR1" D T1^%ZOSV ;stop rt clock
+12 ; Compile and print report.
DO ^IBOTR2
+13 ;
END KILL DIRUT,DTOUT,DUOUT,DIROUT
+1 QUIT
+2 ;
OUT() ; Prompt to allow users to select output format
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 WRITE !
+3 SET DIR(0)="SA^E:Excel;R:Report"
+4 SET DIR("A")="(E)xcel Format or (R)eport Format: "
+5 SET DIR("B")="Report"
+6 ;IB*752/DTG send upcaret if stop
DO ^DIR
IF $DATA(DIRUT)!($EXTRACT(Y)=U)
SET STOP=1
QUIT U
+7 QUIT Y
