- 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 Feb 18, 2025@23:52:39 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 ;