IBOTR ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - USER INTERFACE; 5-JUN-91
;;2.0;INTEGRATED BILLING;**42,100,118,128,743,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCROTR
;
;***
;S XRTL=$ZU(0),XRTN="IBOTR-1" D T0^%ZOSV ;start rt clock
D DT^DICRW,HOME^%ZIS
;
N IBAF,IBAFD,IBAFF,IBAFL,IBAFN,IBARST,IBBC,IBBDT,IBBRN,IBBRT,IBBRTY,IBCANC,IBCFL,IBCNC,IBDA,IBDBC,IBDF,IBDFN,IBDIV,IBDP,IBEDT,IBEVT,IBICF,IBICL,IBINRC,IBPFLAG,IBPRNT,IBPTIN,IBQUIT,IBRT,IBRTN,IBSDIV,IBSORT
N IBAFFO,IBAFLO,IBI,IBICFU,IBICLU,IBRET,IBSCR ;IB*752/DTG - New var's for upper/lower case
S (IBAFFO,IBAFLO,IBICF,IBICFU,IBICL,IBICLU,IBSCR)=""
;
; - Sort by division.
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Do you wish to sort this report by division"
S DIR("?")="^S IBOFF=1 W ! D HELP^IBOTR"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G END
S IBSDIV=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
; - Issue prompt for division.
I IBSDIV D PSDR^IBODIV G:Y<0 END
;
; - Select bill type to print.
S DIC="^DGCR(399.3,",DIC(0)="AEQMN",DIC("S")="I $P(^(0),U,7)=""i"""
W ! D ^DIC K DIC G END:Y<1 S IBRT=+Y,IBRTN=$P(Y,U,2)
;
; - Issue selection field decision prompt.
W !!,"You may select a field from the BILL/CLAIMS file which you may"
W !,"use to limit the selection of records to appear on the report.",!
S DIR(0)="Y",DIR("A")="Do you wish to choose such a field"
S DIR("B")="NO",DIR("?")="^S IBOFF=7 W ! D HELP^IBOTR"
D ^DIR K DIR G END:$D(DIRUT),CONT:'Y
;
; - Issue selection field prompts.
S DIC="^DD(399,",DIC(0)="AEQM",DIC("A")="Select BILL/CLAIMS FIELD: "
S DIC("S")="S IBX=$P(^(0),U,2) I $S('$D(^DD(+IBX,.01,0)):1,$P(^(0),U,2)[""M"":0,1:1)"
D ^DIC K DIC,IBX I Y<0 G CONT
S IBAF=+Y,IBAFN=$P(Y,U,2),IBAFD=$P($G(^DD(399,IBAF,0)),U,2)["D"
;
;IB*743/TAZ - Updated FD1 to FileMan Read and to accept NULL to mean beginning of list.
FD1 ;
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 "_IBAFN
S DIR("?")="^S IBOFF=13 D HELP2^IBOTR,HELP^IBOTR"
; IB*743/DTG have '??' same as '?'
;S DIR("??")="^S IBOFF=7 D HELP1^IBOTR,HELP2^IBOTR,HELP^IBOTR"
S DIR("??")="^S IBOFF=13 D HELP1^IBOTR,HELP2^IBOTR,HELP^IBOTR"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) G END
;IB*752/DTG if name (#.02) make first name upper case
;I "@"[Y S IBAFF=$S(IBAFD&(Y=""):0,1:Y) G FD2
I "@"[Y S IBAFF=$S(IBAFD&(Y=""):0,1:Y) S IBAFFO=IBAFF G FD2
;I IBAFD D ^%DT K %DT S IBAFF=Y I Y<0 K IBAFF W ! S IBOFF=7 D HELP W ! G FD1
I IBAFD D ^%DT K %DT S IBAFF=Y,IBAFFO=IBAFF I Y<0 K IBAFF W ! S IBOFF=7 D HELP W ! G FD1
I 'IBAFD S IBAFF=Y
S IBAFFO=IBAFF I ($G(IBAF)=".02"&('IBAFF)&(IBAFF'="@")) S IBAFFO=$$UP^XLFSTR(IBAFF)
;
;IB*743/TAZ - Updated FD2 to FileMan Read and to accept NULL to mean end of list.
FD2 ;
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 "_IBAFN
S DIR("?")="^S IBOFF=19 D HELP2^IBOTR,HELP^IBOTR"
S DIR("??")="^S IBOFF=19 D HELP1^IBOTR,HELP2^IBOTR,HELP^IBOTR"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) G END
; IB*752/DTG if name (#.02) upper case
;I Y="" S IBAFL=$S(IBAFD:9999999,1:"") S:IBAFF="" IBAFZ="ALL" G CONT
;I Y="@",IBAFF="@" S IBAFL="@",IBAFZ="NULL" G CONT
I Y="" S IBAFL=$S(IBAFD:9999999,1:"") S:IBAFF="" IBAFZ="ALL" S IBAFLO=IBAFL G CONT ;IB*752/DTG
I Y="@",IBAFF="@" S IBAFL="@",IBAFZ="NULL" S IBAFLO=IBAFL G CONT ;IB*752/DTG
I IBAFD D ^%DT K %DT S IBAFL=Y I Y<0!(IBAFF'="@"&(Y<IBAFF)) K IBAFL W !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",! G FD1
I 'IBAFD,+IBAFF=IBAFF,+Y=Y G:Y'<IBAFF FD21 W !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",! G FD1
;IB*752/DTG
;I 'IBAFD,IBAFF'="@",IBAFF]Y W !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",! G FD1
I 'IBAFD,IBAFF'="@",IBAFF]Y,$G(IBAF)'=".02" W !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",! G FD1
I 'IBAFD,IBAFF'="@",$G(IBAF)=".02",IBAFFO]$$UP^XLFSTR(Y) W !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",! G FD1
FD21 I 'IBAFD S IBAFL=Y
S IBAFLO=IBAFL I ($G(IBAF)=".02"&('IBAFL)&(IBAFL'="@")) S IBAFLO=$$UP^XLFSTR(IBAFL) ;IB*752/DTG
;
CONT D ^IBOTR1 ; Continue user interface/compile and print report.
;
END K IBRT,IBRTN,IBADFREF,IBAF,IBAFN,IBAFD,IBAFF,IBAFL,IBAFZ,IBBRT,IBBRN,IBG
K IBDF,IBDFN,IBBDT,IBEDT,IBICF,IBICL,IBIC,IBBRTY,IBOFF,IBTEXT,IBARST
K IBCANC,IBCNC,IBINRC,IBPRNT,IBSDIV,IBSORT,IBICPT,VAUTD
K DIROUT,DTOUT,DUOUT,DIRUT
K IBAFFO,IBAFLO,IBI,IBICFU,IBICLU,IBRET ;IB*752/DTG - New var's for upper/lower case
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOTR" D T1^%ZOSV ;stop rt clock
Q
;
HELP F S IBTEXT=$P($T(TEXT+IBOFF),";",3) Q:IBTEXT="" W !,IBTEXT S IBOFF=IBOFF+1
Q
;
HELP1 W ! S IBX=0 F S IBX=$O(^DD(399,IBAF,21,IBX)) Q:'IBX W:$D(^(IBX,0)) !,^(0)
K IBX Q
;
HELP2 W:$D(^DD(399,IBAF,3)) !!,^(3),! Q
;
TEXT ; - 'Sort by division' prompt.
;; Enter: '<CR>' - To print the report without regard to division
;; 'Y' - To select those divisions for which a separate
;; report should be created
;; '^' - To quit this option
;
; - 'Additional field' prompt.
;; Enter: 'Y' - To select a field from the BILL/CLAIMS file
;; 'N' - To skip this prompt and continue with this
;; option
;; '^' - To quit this option
;
; - 'Start with FIELD NAME' prompt.
;; Enter a valid field value, or
;; '@' - To include null values
;; '<ENTER>' - To start from the 'first' value for this field
;; '^' - To quit this option
;
; - 'Go to FIELD NAME' prompt.
;; Enter a valid field value, or
;; '@' - To include only null values, if 'Start with'
;; value is @
;; '<ENTER>' - To go to the 'last' value for this field
;; '^' - To quit this option
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOTR 6171 printed Dec 13, 2024@02:26:09 Page 2
IBOTR ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - USER INTERFACE; 5-JUN-91
+1 ;;2.0;INTEGRATED BILLING;**42,100,118,128,743,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCROTR
+5 ;
+6 ;***
+7 ;S XRTL=$ZU(0),XRTN="IBOTR-1" D T0^%ZOSV ;start rt clock
+8 DO DT^DICRW
DO HOME^%ZIS
+9 ;
+10 NEW IBAF,IBAFD,IBAFF,IBAFL,IBAFN,IBARST,IBBC,IBBDT,IBBRN,IBBRT,IBBRTY,IBCANC,IBCFL,IBCNC,IBDA,IBDBC,IBDF,IBDFN,IBDIV,IBDP,IBEDT,IBEVT,IBICF,IBICL,IBINRC,IBPFLAG,IBPRNT,IBPTIN,IBQUIT,IBRT,IBRTN,IBSDIV,IBSORT
+11 ;IB*752/DTG - New var's for upper/lower case
NEW IBAFFO,IBAFLO,IBI,IBICFU,IBICLU,IBRET,IBSCR
+12 SET (IBAFFO,IBAFLO,IBICF,IBICFU,IBICL,IBICLU,IBSCR)=""
+13 ;
+14 ; - Sort by division.
+15 SET DIR(0)="Y"
SET DIR("B")="NO"
+16 SET DIR("A")="Do you wish to sort this report by division"
+17 SET DIR("?")="^S IBOFF=1 W ! D HELP^IBOTR"
+18 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO END
+19 SET IBSDIV=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+20 ;
+21 ; - Issue prompt for division.
+22 IF IBSDIV
DO PSDR^IBODIV
if Y<0
GOTO END
+23 ;
+24 ; - Select bill type to print.
+25 SET DIC="^DGCR(399.3,"
SET DIC(0)="AEQMN"
SET DIC("S")="I $P(^(0),U,7)=""i"""
+26 WRITE !
DO ^DIC
KILL DIC
if Y<1
GOTO END
SET IBRT=+Y
SET IBRTN=$PIECE(Y,U,2)
+27 ;
+28 ; - Issue selection field decision prompt.
+29 WRITE !!,"You may select a field from the BILL/CLAIMS file which you may"
+30 WRITE !,"use to limit the selection of records to appear on the report.",!
+31 SET DIR(0)="Y"
SET DIR("A")="Do you wish to choose such a field"
+32 SET DIR("B")="NO"
SET DIR("?")="^S IBOFF=7 W ! D HELP^IBOTR"
+33 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
if 'Y
GOTO CONT
+34 ;
+35 ; - Issue selection field prompts.
+36 SET DIC="^DD(399,"
SET DIC(0)="AEQM"
SET DIC("A")="Select BILL/CLAIMS FIELD: "
+37 SET DIC("S")="S IBX=$P(^(0),U,2) I $S('$D(^DD(+IBX,.01,0)):1,$P(^(0),U,2)[""M"":0,1:1)"
+38 DO ^DIC
KILL DIC,IBX
IF Y<0
GOTO CONT
+39 SET IBAF=+Y
SET IBAFN=$PIECE(Y,U,2)
SET IBAFD=$PIECE($GET(^DD(399,IBAF,0)),U,2)["D"
+40 ;
+41 ;IB*743/TAZ - Updated FD1 to FileMan Read and to accept NULL to mean beginning of list.
FD1 ;
+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 "_IBAFN
+5 SET DIR("?")="^S IBOFF=13 D HELP2^IBOTR,HELP^IBOTR"
+6 ; IB*743/DTG have '??' same as '?'
+7 ;S DIR("??")="^S IBOFF=7 D HELP1^IBOTR,HELP2^IBOTR,HELP^IBOTR"
+8 SET DIR("??")="^S IBOFF=13 D HELP1^IBOTR,HELP2^IBOTR,HELP^IBOTR"
+9 DO ^DIR
+10 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO END
+11 ;IB*752/DTG if name (#.02) make first name upper case
+12 ;I "@"[Y S IBAFF=$S(IBAFD&(Y=""):0,1:Y) G FD2
+13 IF "@"[Y
SET IBAFF=$SELECT(IBAFD&(Y=""):0,1:Y)
SET IBAFFO=IBAFF
GOTO FD2
+14 ;I IBAFD D ^%DT K %DT S IBAFF=Y I Y<0 K IBAFF W ! S IBOFF=7 D HELP W ! G FD1
+15 IF IBAFD
DO ^%DT
KILL %DT
SET IBAFF=Y
SET IBAFFO=IBAFF
IF Y<0
KILL IBAFF
WRITE !
SET IBOFF=7
DO HELP
WRITE !
GOTO FD1
+16 IF 'IBAFD
SET IBAFF=Y
+17 SET IBAFFO=IBAFF
IF ($GET(IBAF)=".02"&('IBAFF)&(IBAFF'="@"))
SET IBAFFO=$$UP^XLFSTR(IBAFF)
+18 ;
+19 ;IB*743/TAZ - Updated FD2 to FileMan Read and to accept NULL to mean end of list.
FD2 ;
+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 "_IBAFN
+4 SET DIR("?")="^S IBOFF=19 D HELP2^IBOTR,HELP^IBOTR"
+5 SET DIR("??")="^S IBOFF=19 D HELP1^IBOTR,HELP2^IBOTR,HELP^IBOTR"
+6 DO ^DIR
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO END
+8 ; IB*752/DTG if name (#.02) upper case
+9 ;I Y="" S IBAFL=$S(IBAFD:9999999,1:"") S:IBAFF="" IBAFZ="ALL" G CONT
+10 ;I Y="@",IBAFF="@" S IBAFL="@",IBAFZ="NULL" G CONT
+11 ;IB*752/DTG
IF Y=""
SET IBAFL=$SELECT(IBAFD:9999999,1:"")
if IBAFF=""
SET IBAFZ="ALL"
SET IBAFLO=IBAFL
GOTO CONT
+12 ;IB*752/DTG
IF Y="@"
IF IBAFF="@"
SET IBAFL="@"
SET IBAFZ="NULL"
SET IBAFLO=IBAFL
GOTO CONT
+13 IF IBAFD
DO ^%DT
KILL %DT
SET IBAFL=Y
IF Y<0!(IBAFF'="@"&(Y<IBAFF))
KILL IBAFL
WRITE !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",!
GOTO FD1
+14 IF 'IBAFD
IF +IBAFF=IBAFF
IF +Y=Y
if Y'<IBAFF
GOTO FD21
WRITE !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",!
GOTO FD1
+15 ;IB*752/DTG
+16 ;I 'IBAFD,IBAFF'="@",IBAFF]Y W !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",! G FD1
+17 IF 'IBAFD
IF IBAFF'="@"
IF IBAFF]Y
IF $GET(IBAF)'=".02"
WRITE !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",!
GOTO FD1
+18 IF 'IBAFD
IF IBAFF'="@"
IF $GET(IBAF)=".02"
IF IBAFFO]$$UP^XLFSTR(Y)
WRITE !!?3,"The Go To "_IBAFN_" must follow the Start With "_IBAFN_".",!
GOTO FD1
FD21 IF 'IBAFD
SET IBAFL=Y
+1 ;IB*752/DTG
SET IBAFLO=IBAFL
IF ($GET(IBAF)=".02"&('IBAFL)&(IBAFL'="@"))
SET IBAFLO=$$UP^XLFSTR(IBAFL)
+2 ;
CONT ; Continue user interface/compile and print report.
DO ^IBOTR1
+1 ;
END KILL IBRT,IBRTN,IBADFREF,IBAF,IBAFN,IBAFD,IBAFF,IBAFL,IBAFZ,IBBRT,IBBRN,IBG
+1 KILL IBDF,IBDFN,IBBDT,IBEDT,IBICF,IBICL,IBIC,IBBRTY,IBOFF,IBTEXT,IBARST
+2 KILL IBCANC,IBCNC,IBINRC,IBPRNT,IBSDIV,IBSORT,IBICPT,VAUTD
+3 KILL DIROUT,DTOUT,DUOUT,DIRUT
+4 ;IB*752/DTG - New var's for upper/lower case
KILL IBAFFO,IBAFLO,IBI,IBICFU,IBICLU,IBRET
+5 ;***
+6 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOTR" D T1^%ZOSV ;stop rt clock
+7 QUIT
+8 ;
HELP FOR
SET IBTEXT=$PIECE($TEXT(TEXT+IBOFF),";",3)
if IBTEXT=""
QUIT
WRITE !,IBTEXT
SET IBOFF=IBOFF+1
+1 QUIT
+2 ;
HELP1 WRITE !
SET IBX=0
FOR
SET IBX=$ORDER(^DD(399,IBAF,21,IBX))
if 'IBX
QUIT
if $DATA(^(IBX,0))
WRITE !,^(0)
+1 KILL IBX
QUIT
+2 ;
HELP2 if $DATA(^DD(399,IBAF,3))
WRITE !!,^(3),!
QUIT
+1 ;
TEXT ; - 'Sort by division' prompt.
+1 ;; Enter: '<CR>' - To print the report without regard to division
+2 ;; 'Y' - To select those divisions for which a separate
+3 ;; report should be created
+4 ;; '^' - To quit this option
+5 ;
+6 ; - 'Additional field' prompt.
+7 ;; Enter: 'Y' - To select a field from the BILL/CLAIMS file
+8 ;; 'N' - To skip this prompt and continue with this
+9 ;; option
+10 ;; '^' - To quit this option
+11 ;
+12 ; - 'Start with FIELD NAME' prompt.
+13 ;; Enter a valid field value, or
+14 ;; '@' - To include null values
+15 ;; '<ENTER>' - To start from the 'first' value for this field
+16 ;; '^' - To quit this option
+17 ;
+18 ; - 'Go to FIELD NAME' prompt.
+19 ;; Enter a valid field value, or
+20 ;; '@' - To include only null values, if 'Start with'
+21 ;; value is @
+22 ;; '<ENTER>' - To go to the 'last' value for this field
+23 ;; '^' - To quit this option
+24 ;
