IBCOMA ;ALB/CMS/JNM - IDENTIFY ACTIVE POLICIES W/NO EFFECTIVE DATE; 09-29-2015
;;2.0;INTEGRATED BILLING;**103,528,549,743,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
Q
EN ;Entry point from option
; IBAIB - 1 (Patient Name Range) or 2 (Terminal Digit Range) sorting method
; IBAPPTE - Ending Appointment Date for filtering
; IBAPPTS - Starting Appointment Date for filtering
; IBBDT - Beginning Verification Date for filtering
; IBEDT - Ending Verification Date for filtering
; IBEXCEL - 1 for Excel Format, 0 for Report Format
; IBRF - First Patient Name or Terminal Digit, depending on sorting method
; IBRL - Last Patient Name or Terminal Digit, depending on sorting method
; IBPTYPE - 1 (Living Patients), 2 (Deceased Patients) or 3 (Both)
; IBSIN - 1 (Verified Policies), 2 (Non-Verified Policies) or 3 (Both)
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBAIB,IBAPPTE,IBAPPTS,IBBDT,IBEDT,IBEXCEL,IBRF
N IBRL,IBPTYPE,IBQUIT,IBSIN,X,Y
N IBRFU,IBRLU ;IB*752/DTG added for case insensitive
STRT ;
S (IBRFU,IBRLU)=""
S (IBAIB,IBBDT,IBEDT,IBRF,IBRL,IBSIN,IBQUIT,IBAPPTS,IBAPPTE,IBEXCEL)=""
W !!,?10,"Identify Active Policies with NO Effective Date",!
S DIR("A",1)="Filter report by" ;IB*752/DTG change Sort to Filter
S DIR("A",2)=" 1 - Patient Name Range"
S DIR("A",3)=" 2 - Terminal Digit Range"
S DIR("A",4)=" "
S DIR(0)="SAB^1:Patient Name;2:Terminal Digit" ;IB*752/DTG change SAXB to SAB to allow lower case
S DIR("A")=" Select Number: ",DIR("B")="1",DIR("??")="^D ENH^IBCOMA"
D ^DIR
I +Y'>0 G EXIT
S IBAIB=+Y
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
W !!
D @$S(IBAIB=1:"NR",1:"TR")
;I IBQUIT=1 G EXIT
I IBQUIT=1 G STRT
;
PATLIFE ; IB*2*549 - Prompt for Living/Deceased Patient filter
W !!
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR("A",1)=$$WITEXT()
S DIR("A",2)=" 1 - Living Patients"
S DIR("A",3)=" 2 - Deceased Patients"
S DIR("A",4)=" 3 - Both"
S DIR("A",5)=" "
S DIR(0)="SAB^1:Living Patients;2:Deceased Patients;3:Both" ;IB*752/DTG change SAXB to SAB to allow lower case
S DIR("A")=" Select Number: ",DIR("B")="1",DIR("??")="^D PATLIFEH^IBCOMA"
D ^DIR
I $D(DUOUT) G STRT
I +Y'>0 G EXIT
S IBPTYPE=Y
;
VER ;
W !!
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR("A",1)=$$WITEXT()
S DIR("A",2)=" 1 - Verified Policies"
S DIR("A",3)=" 2 - Non-Verified Policies"
S DIR("A",4)=" 3 - Both"
S DIR("A",5)=" "
S DIR(0)="SAB^1:Verified Policies;2:Non-Verified Policies;3:Both" ;IB*752/DTG change SAXB to SAB to allow lower case
S DIR("A")=" Select Number: ",DIR("B")="1",DIR("??")="^D ICH^IBCOMA" D ^DIR
I $D(DUOUT) G PATLIFE
I +Y'>0 G EXIT
S IBSIN=+Y
;
FILTYPE ; IB.2.0.549 added method
S (IBBDT,IBEDT,IBAPPTS,IBAPPTE)=0
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
I IBSIN>1 G LADATE
W !!
S DIR("A",1)="Filter data by:"
S DIR("A",2)=" 1 - Policy Verification Date"
S DIR("A",3)=" 2 - Last Appointment Date"
S DIR("A",4)=" "
S DIR(0)="SAB^1:Policy Verification Date;2:Last Appointment Date" ;IB*752/DTG change SAXB to SAB to allow lower case
S DIR("A")=" Select Number: ",DIR("B")="1",DIR("??")="^D FILTYPEH^IBCOMA"
D ^DIR
I $D(DUOUT) G VER
I +Y'>0 G EXIT
I Y=2 G LADATE
;
PVDATE ;
N UPMOD
I '$$GETDATES("Policy Verification",.IBBDT,.IBEDT) S UPMOD=$S(+$G(IBSIN)>1:"VER",1:"FILTYPE") G @UPMOD
I IBQUIT=1 G EXIT
G FORMAT
;
LADATE ;
;
; IB*2*549 - Prompt for Last Appointment Date Range
N UPMOD
W !!
I '$$GETDATES("Last Appointment",.IBAPPTS,.IBAPPTE) S UPMOD=$S(+$G(IBSIN)>1:"VER",1:"FILTYPE") G @UPMOD
I IBQUIT=1 G EXIT
;
FORMAT ; Prompt for Excel or Report Format
W !
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
S DIR(0)="SA^E:Excel;R:Report"
S DIR("A")="(E)xcel Format or (R)eport Format: "
S DIR("B")="Report",DIR("??")="^D FORMATH^IBCOMA"
D ^DIR
S Y=$$UP^XLFSTR(Y) ; make sure answer is upper case
S IBEXCEL=$S(Y="E":1,Y="R":0,1:-1)
I IBEXCEL<0 G EXIT
;
W !!
D QUE
;
EXIT ;
Q
;
WITEXT() ;
Q " Within "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Include:"
;
FORMATH ; Excel or Report Format Help
W !,?5,"Enter E to Export data in a format readable by Microsoft Excel."
W !,?5,"Enter R to display output in Report format."
Q
;
NR ; Ask Name Range
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
NRR ;
;IB*743/TAZ - Updated code to accept NULL to mean beginning of list.
W !!,"Enter Start With value or Press <ENTER> to start at the beginning of the list.",!
S DIR(0)="FO",DIR("A")="START WITH PATIENT NAME"
S DIR("?")="^D NRRHLP^IBCOMN(""BEGIN"")"
D ^DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S IBRF=Y
S IBRFU=$$UP^XLFSTR(IBRF) ;IB*752/DTG - change user's response to upper case
;
;IB*743/TAZ - Updated code to accept NULL to mean end of list.
W !!,"Enter Go To value or Press <ENTER> to finish at the end of the list.",!
S DIR(0)="FO",DIR("A")="GO TO PATIENT NAME"
S DIR("?")="^D NRRHLP^IBCOMN(""END"")"
;IB*752/DTG go back to NRR instead of quit on '^'
;D ^DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
D ^DIR
I ($D(DTOUT))!($D(DUOUT)) G NRR
S:Y="" Y="zzzzzz" S IBRL=Y
;IB*752/DTG - change user's response to upper case
S IBRLU=IBRL I IBRL'="zzzzzz" S IBRLU=$$UP^XLFSTR(IBRL)
;I $G(IBRL)']$G(IBRF) W !!,?5,"* The Go to Patient Name must follow after the Start with Name. *",! G NRR
I $G(IBRLU)']$G(IBRFU) W !!,?5,"* The Go to Patient Name must follow after the Start with Name. *",! G NRR
Q
;
NRRHLP(LEVEL) ; ?? Help for the Range Prompt
W !!,?5,"Enter a value the Patient Name should ",LEVEL," with."
I LEVEL="BEGIN" W !,?5,"Press <ENTER> to start at the beginning of the list."
I LEVEL="END" W !,?5,"Press <ENTER> to finish at the end of the list."
Q
;
TR ; Ask Terminal Digit Range
N DIR,DIRUT,DUOUT,DTOUT,X,Y
TRR ; IB*752/DTG new tag for return to if '^' on go to prompt
S DIR(0)="FO^1:9^K:X'?1.9N X"
S DIR("?")="Enter up to 9 digits of the Terminal Digit to include in Report"
S DIR("B")="0000",DIR("A")=" Start with Terminal Digit"
D ^DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S IBRF=$E((Y_"000000000"),1,9)
S DIR("B")="9999",DIR("A")=" GO to Terminal Digit"
;IB*752/DTG go to TRR instead of quit on '^'
;D ^DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
D ^DIR
I ($D(DTOUT))!($D(DUOUT)) G TRR
S IBRL=$E((Y_"999999999"),1,9)
I IBRF>IBRL W !!,?5,"* The Go to Terminal Digit must follow after the Start with Digit. *",! G TR
Q
;
PATLIFEH ; Living/Deceased/Both patient filter help Text
W !!,?5,"Enter 1 to only display Living Patients."
W !,?5,"Enter 2 to only display Deceased Patients."
W !,?5,"Enter 3 to display both Living and Deceased Patients."
Q
;
FILTYPEH ; Filter by Verification Date or Last Appointment Date Help Text
W !!,?5,"Enter 1 to only display policies with a Verification Date falling"
W !,?11,"within a specified date range."
W !,?5,"Enter 2 to only display patients with a Last Appointment Date falling"
W !,?11,"within a specified date range."
Q
;
GETDATES(TEXT,STRTDATE,ENDDATE) ; Ask Date Range
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
N %DT,X,Y
W !!," Please enter ",TEXT," Dates:"
;
VRBDT ; - get begin date
S (STRTDATE,ENDDATE)=""
S %DT="AEX",%DT("A")=" Start with DATE: " D ^%DT K %DT G VRQ:Y<0 S STRTDATE=Y
;
VREDT ; - get ending date
;IB*752/DTG go back to VRBDT if '^'
;S %DT="EX" R !," Go to DATE: ",X:DTIME S:X=" " X=STRTDATE G VRQ:(X="")!(X["^") D ^%DT G VREDT:Y<0 S ENDDATE=Y I Y<STRTDATE W *7," ??",!,"ENDING DATE must follow BEGINNING DATE." G VRBDT
S %DT="EX" R !," Go to DATE: ",X:DTIME S:X=" " X=STRTDATE
I X="" G VRQ
I X["^" G VRBDT
D ^%DT G VREDT:Y<0 S ENDDATE=Y
I Y<STRTDATE W *7," ??",!,"ENDING DATE must follow BEGINNING DATE." G VRBDT
;
VRQ ;
I (STRTDATE="")!(ENDDATE="") W " <Date Range not entered>" Q 0
Q 1
;
ENH ; Sort help Text
W !!,?5,"Enter 1 to search by a Patient Name Range. (i.e. ADAMS to ADAMSZ)"
W !!,?5,"Enter 2 to search by Terminal Digit. The output will be sorted"
W !?5,"by the 8th and 9th digits and then the 6th and 7th digits"
W !?5,"of the Patient's SSN.",!
Q
;
ICH ; Search criteria help Text
W !!,?5,"Enter 1 to list active policies by Verification Date Range"
W !,?15,"(i.e. Sort Date By: 10-1-96 Go to Date: 01-1-97)"
W !,?5,"Enter 2 to list active policies with no Verification Date."
W !,?5,"Enter 3 to include active policies with or without a Verification Date."
Q
QUE ; Ask Device
N POP,%ZIS,ZTRTN,ZTSAVE,ZTDESC
I 'IBEXCEL D
.W !,?10,"You may want to queue this report!"
.W !,?10,"Report requires 132 columns.",!
I IBEXCEL D
.W !,"To avoid undesired wrapping, please enter ""0;256;999"" at the 'DEVICE:' prompt.",!
S %ZIS="QM" D ^%ZIS G:POP QUEQ
I $D(IO("Q")) K IO("Q") D G QUEQ
. S ZTRTN="BEG^IBCOMA1",ZTSAVE("IBRF")="",ZTSAVE("IBRL")=""
. S ZTSAVE("IBAIB")="",ZTSAVE("IBBDT")="",ZTSAVE("IBEDT")="",ZTSAVE("IBSIN")=""
. S ZTSAVE("IBPTYPE")="",ZTSAVE("IBAPPTS")="",ZTSAVE("IBAPPTE")="",ZTSAVE("IBEXCEL")=""
. S ZTSAVE("IBRFU")="",ZTSAVE("IBRLU")="" ;IB*752/DTG - include in ZTSAVE
. S ZTDESC="IB - Identify Active Policies w/no Effective Date"
. D ^%ZTLOAD
. K ZTSK
. D HOME^%ZIS
;
U IO
I $E(IOST,1,2)["C-" W !!,?15,"... One Moment Please ..."
D BEG^IBCOMA1
;
QUEQ ; EXIT CLEAN-UP
W !
D ^%ZISC
K IBAIB,IBRF,IBRL,IBSIN,IBPTYPE,IBAPPTS,IBAPPTE,IBEXCEL,^TMP("IBCOMA",$J)
K IBRFU,IBRLU ;IB*752/DTG var's for case insensitive
Q
;IBCOMA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCOMA 9539 printed Dec 13, 2024@02:18:16 Page 2
IBCOMA ;ALB/CMS/JNM - IDENTIFY ACTIVE POLICIES W/NO EFFECTIVE DATE; 09-29-2015
+1 ;;2.0;INTEGRATED BILLING;**103,528,549,743,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
EN ;Entry point from option
+1 ; IBAIB - 1 (Patient Name Range) or 2 (Terminal Digit Range) sorting method
+2 ; IBAPPTE - Ending Appointment Date for filtering
+3 ; IBAPPTS - Starting Appointment Date for filtering
+4 ; IBBDT - Beginning Verification Date for filtering
+5 ; IBEDT - Ending Verification Date for filtering
+6 ; IBEXCEL - 1 for Excel Format, 0 for Report Format
+7 ; IBRF - First Patient Name or Terminal Digit, depending on sorting method
+8 ; IBRL - Last Patient Name or Terminal Digit, depending on sorting method
+9 ; IBPTYPE - 1 (Living Patients), 2 (Deceased Patients) or 3 (Both)
+10 ; IBSIN - 1 (Verified Policies), 2 (Non-Verified Policies) or 3 (Both)
+11 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBAIB,IBAPPTE,IBAPPTS,IBBDT,IBEDT,IBEXCEL,IBRF
+12 NEW IBRL,IBPTYPE,IBQUIT,IBSIN,X,Y
+13 ;IB*752/DTG added for case insensitive
NEW IBRFU,IBRLU
STRT ;
+1 SET (IBRFU,IBRLU)=""
+2 SET (IBAIB,IBBDT,IBEDT,IBRF,IBRL,IBSIN,IBQUIT,IBAPPTS,IBAPPTE,IBEXCEL)=""
+3 WRITE !!,?10,"Identify Active Policies with NO Effective Date",!
+4 ;IB*752/DTG change Sort to Filter
SET DIR("A",1)="Filter report by"
+5 SET DIR("A",2)=" 1 - Patient Name Range"
+6 SET DIR("A",3)=" 2 - Terminal Digit Range"
+7 SET DIR("A",4)=" "
+8 ;IB*752/DTG change SAXB to SAB to allow lower case
SET DIR(0)="SAB^1:Patient Name;2:Terminal Digit"
+9 SET DIR("A")=" Select Number: "
SET DIR("B")="1"
SET DIR("??")="^D ENH^IBCOMA"
+10 DO ^DIR
+11 IF +Y'>0
GOTO EXIT
+12 SET IBAIB=+Y
+13 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+14 WRITE !!
+15 DO @$SELECT(IBAIB=1:"NR",1:"TR")
+16 ;I IBQUIT=1 G EXIT
+17 IF IBQUIT=1
GOTO STRT
+18 ;
PATLIFE ; IB*2*549 - Prompt for Living/Deceased Patient filter
+1 WRITE !!
+2 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 SET DIR("A",1)=$$WITEXT()
+4 SET DIR("A",2)=" 1 - Living Patients"
+5 SET DIR("A",3)=" 2 - Deceased Patients"
+6 SET DIR("A",4)=" 3 - Both"
+7 SET DIR("A",5)=" "
+8 ;IB*752/DTG change SAXB to SAB to allow lower case
SET DIR(0)="SAB^1:Living Patients;2:Deceased Patients;3:Both"
+9 SET DIR("A")=" Select Number: "
SET DIR("B")="1"
SET DIR("??")="^D PATLIFEH^IBCOMA"
+10 DO ^DIR
+11 IF $DATA(DUOUT)
GOTO STRT
+12 IF +Y'>0
GOTO EXIT
+13 SET IBPTYPE=Y
+14 ;
VER ;
+1 WRITE !!
+2 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 SET DIR("A",1)=$$WITEXT()
+4 SET DIR("A",2)=" 1 - Verified Policies"
+5 SET DIR("A",3)=" 2 - Non-Verified Policies"
+6 SET DIR("A",4)=" 3 - Both"
+7 SET DIR("A",5)=" "
+8 ;IB*752/DTG change SAXB to SAB to allow lower case
SET DIR(0)="SAB^1:Verified Policies;2:Non-Verified Policies;3:Both"
+9 SET DIR("A")=" Select Number: "
SET DIR("B")="1"
SET DIR("??")="^D ICH^IBCOMA"
DO ^DIR
+10 IF $DATA(DUOUT)
GOTO PATLIFE
+11 IF +Y'>0
GOTO EXIT
+12 SET IBSIN=+Y
+13 ;
FILTYPE ; IB.2.0.549 added method
+1 SET (IBBDT,IBEDT,IBAPPTS,IBAPPTE)=0
+2 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 IF IBSIN>1
GOTO LADATE
+4 WRITE !!
+5 SET DIR("A",1)="Filter data by:"
+6 SET DIR("A",2)=" 1 - Policy Verification Date"
+7 SET DIR("A",3)=" 2 - Last Appointment Date"
+8 SET DIR("A",4)=" "
+9 ;IB*752/DTG change SAXB to SAB to allow lower case
SET DIR(0)="SAB^1:Policy Verification Date;2:Last Appointment Date"
+10 SET DIR("A")=" Select Number: "
SET DIR("B")="1"
SET DIR("??")="^D FILTYPEH^IBCOMA"
+11 DO ^DIR
+12 IF $DATA(DUOUT)
GOTO VER
+13 IF +Y'>0
GOTO EXIT
+14 IF Y=2
GOTO LADATE
+15 ;
PVDATE ;
+1 NEW UPMOD
+2 IF '$$GETDATES("Policy Verification",.IBBDT,.IBEDT)
SET UPMOD=$SELECT(+$GET(IBSIN)>1:"VER",1:"FILTYPE")
GOTO @UPMOD
+3 IF IBQUIT=1
GOTO EXIT
+4 GOTO FORMAT
+5 ;
LADATE ;
+1 ;
+2 ; IB*2*549 - Prompt for Last Appointment Date Range
+3 NEW UPMOD
+4 WRITE !!
+5 IF '$$GETDATES("Last Appointment",.IBAPPTS,.IBAPPTE)
SET UPMOD=$SELECT(+$GET(IBSIN)>1:"VER",1:"FILTYPE")
GOTO @UPMOD
+6 IF IBQUIT=1
GOTO EXIT
+7 ;
FORMAT ; Prompt for Excel or Report Format
+1 WRITE !
+2 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+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"
SET DIR("??")="^D FORMATH^IBCOMA"
+6 DO ^DIR
+7 ; make sure answer is upper case
SET Y=$$UP^XLFSTR(Y)
+8 SET IBEXCEL=$SELECT(Y="E":1,Y="R":0,1:-1)
+9 IF IBEXCEL<0
GOTO EXIT
+10 ;
+11 WRITE !!
+12 DO QUE
+13 ;
EXIT ;
+1 QUIT
+2 ;
WITEXT() ;
+1 QUIT " Within "_$SELECT(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Include:"
+2 ;
FORMATH ; Excel or Report Format Help
+1 WRITE !,?5,"Enter E to Export data in a format readable by Microsoft Excel."
+2 WRITE !,?5,"Enter R to display output in Report format."
+3 QUIT
+4 ;
NR ; Ask Name Range
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
NRR ;
+1 ;IB*743/TAZ - Updated code to accept NULL to mean beginning of list.
+2 WRITE !!,"Enter Start With value or Press <ENTER> to start at the beginning of the list.",!
+3 SET DIR(0)="FO"
SET DIR("A")="START WITH PATIENT NAME"
+4 SET DIR("?")="^D NRRHLP^IBCOMN(""BEGIN"")"
+5 DO ^DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+6 SET IBRF=Y
+7 ;IB*752/DTG - change user's response to upper case
SET IBRFU=$$UP^XLFSTR(IBRF)
+8 ;
+9 ;IB*743/TAZ - Updated code to accept NULL to mean end of list.
+10 WRITE !!,"Enter Go To value or Press <ENTER> to finish at the end of the list.",!
+11 SET DIR(0)="FO"
SET DIR("A")="GO TO PATIENT NAME"
+12 SET DIR("?")="^D NRRHLP^IBCOMN(""END"")"
+13 ;IB*752/DTG go back to NRR instead of quit on '^'
+14 ;D ^DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
+15 DO ^DIR
+16 IF ($DATA(DTOUT))!($DATA(DUOUT))
GOTO NRR
+17 if Y=""
SET Y="zzzzzz"
SET IBRL=Y
+18 ;IB*752/DTG - change user's response to upper case
+19 SET IBRLU=IBRL
IF IBRL'="zzzzzz"
SET IBRLU=$$UP^XLFSTR(IBRL)
+20 ;I $G(IBRL)']$G(IBRF) W !!,?5,"* The Go to Patient Name must follow after the Start with Name. *",! G NRR
+21 IF $GET(IBRLU)']$GET(IBRFU)
WRITE !!,?5,"* The Go to Patient Name must follow after the Start with Name. *",!
GOTO NRR
+22 QUIT
+23 ;
NRRHLP(LEVEL) ; ?? Help for the Range Prompt
+1 WRITE !!,?5,"Enter a value the Patient Name should ",LEVEL," with."
+2 IF LEVEL="BEGIN"
WRITE !,?5,"Press <ENTER> to start at the beginning of the list."
+3 IF LEVEL="END"
WRITE !,?5,"Press <ENTER> to finish at the end of the list."
+4 QUIT
+5 ;
TR ; Ask Terminal Digit Range
+1 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y
TRR ; IB*752/DTG new tag for return to if '^' on go to prompt
+1 SET DIR(0)="FO^1:9^K:X'?1.9N X"
+2 SET DIR("?")="Enter up to 9 digits of the Terminal Digit to include in Report"
+3 SET DIR("B")="0000"
SET DIR("A")=" Start with Terminal Digit"
+4 DO ^DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+5 SET IBRF=$EXTRACT((Y_"000000000"),1,9)
+6 SET DIR("B")="9999"
SET DIR("A")=" GO to Terminal Digit"
+7 ;IB*752/DTG go to TRR instead of quit on '^'
+8 ;D ^DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
+9 DO ^DIR
+10 IF ($DATA(DTOUT))!($DATA(DUOUT))
GOTO TRR
+11 SET IBRL=$EXTRACT((Y_"999999999"),1,9)
+12 IF IBRF>IBRL
WRITE !!,?5,"* The Go to Terminal Digit must follow after the Start with Digit. *",!
GOTO TR
+13 QUIT
+14 ;
PATLIFEH ; Living/Deceased/Both patient filter help Text
+1 WRITE !!,?5,"Enter 1 to only display Living Patients."
+2 WRITE !,?5,"Enter 2 to only display Deceased Patients."
+3 WRITE !,?5,"Enter 3 to display both Living and Deceased Patients."
+4 QUIT
+5 ;
FILTYPEH ; Filter by Verification Date or Last Appointment Date Help Text
+1 WRITE !!,?5,"Enter 1 to only display policies with a Verification Date falling"
+2 WRITE !,?11,"within a specified date range."
+3 WRITE !,?5,"Enter 2 to only display patients with a Last Appointment Date falling"
+4 WRITE !,?11,"within a specified date range."
+5 QUIT
+6 ;
GETDATES(TEXT,STRTDATE,ENDDATE) ; Ask Date Range
+1 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
+2 NEW %DT,X,Y
+3 WRITE !!," Please enter ",TEXT," Dates:"
+4 ;
VRBDT ; - get begin date
+1 SET (STRTDATE,ENDDATE)=""
+2 SET %DT="AEX"
SET %DT("A")=" Start with DATE: "
DO ^%DT
KILL %DT
if Y<0
GOTO VRQ
SET STRTDATE=Y
+3 ;
VREDT ; - get ending date
+1 ;IB*752/DTG go back to VRBDT if '^'
+2 ;S %DT="EX" R !," Go to DATE: ",X:DTIME S:X=" " X=STRTDATE G VRQ:(X="")!(X["^") D ^%DT G VREDT:Y<0 S ENDDATE=Y I Y<STRTDATE W *7," ??",!,"ENDING DATE must follow BEGINNING DATE." G VRBDT
+3 SET %DT="EX"
READ !," Go to DATE: ",X:DTIME
if X=" "
SET X=STRTDATE
+4 IF X=""
GOTO VRQ
+5 IF X["^"
GOTO VRBDT
+6 DO ^%DT
if Y<0
GOTO VREDT
SET ENDDATE=Y
+7 IF Y<STRTDATE
WRITE *7," ??",!,"ENDING DATE must follow BEGINNING DATE."
GOTO VRBDT
+8 ;
VRQ ;
+1 IF (STRTDATE="")!(ENDDATE="")
WRITE " <Date Range not entered>"
QUIT 0
+2 QUIT 1
+3 ;
ENH ; Sort help Text
+1 WRITE !!,?5,"Enter 1 to search by a Patient Name Range. (i.e. ADAMS to ADAMSZ)"
+2 WRITE !!,?5,"Enter 2 to search by Terminal Digit. The output will be sorted"
+3 WRITE !?5,"by the 8th and 9th digits and then the 6th and 7th digits"
+4 WRITE !?5,"of the Patient's SSN.",!
+5 QUIT
+6 ;
ICH ; Search criteria help Text
+1 WRITE !!,?5,"Enter 1 to list active policies by Verification Date Range"
+2 WRITE !,?15,"(i.e. Sort Date By: 10-1-96 Go to Date: 01-1-97)"
+3 WRITE !,?5,"Enter 2 to list active policies with no Verification Date."
+4 WRITE !,?5,"Enter 3 to include active policies with or without a Verification Date."
+5 QUIT
QUE ; Ask Device
+1 NEW POP,%ZIS,ZTRTN,ZTSAVE,ZTDESC
+2 IF 'IBEXCEL
Begin DoDot:1
+3 WRITE !,?10,"You may want to queue this report!"
+4 WRITE !,?10,"Report requires 132 columns.",!
End DoDot:1
+5 IF IBEXCEL
Begin DoDot:1
+6 WRITE !,"To avoid undesired wrapping, please enter ""0;256;999"" at the 'DEVICE:' prompt.",!
End DoDot:1
+7 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUEQ
+8 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:1
+9 SET ZTRTN="BEG^IBCOMA1"
SET ZTSAVE("IBRF")=""
SET ZTSAVE("IBRL")=""
+10 SET ZTSAVE("IBAIB")=""
SET ZTSAVE("IBBDT")=""
SET ZTSAVE("IBEDT")=""
SET ZTSAVE("IBSIN")=""
+11 SET ZTSAVE("IBPTYPE")=""
SET ZTSAVE("IBAPPTS")=""
SET ZTSAVE("IBAPPTE")=""
SET ZTSAVE("IBEXCEL")=""
+12 ;IB*752/DTG - include in ZTSAVE
SET ZTSAVE("IBRFU")=""
SET ZTSAVE("IBRLU")=""
+13 SET ZTDESC="IB - Identify Active Policies w/no Effective Date"
+14 DO ^%ZTLOAD
+15 KILL ZTSK
+16 DO HOME^%ZIS
End DoDot:1
GOTO QUEQ
+17 ;
+18 USE IO
+19 IF $EXTRACT(IOST,1,2)["C-"
WRITE !!,?15,"... One Moment Please ..."
+20 DO BEG^IBCOMA1
+21 ;
QUEQ ; EXIT CLEAN-UP
+1 WRITE !
+2 DO ^%ZISC
+3 KILL IBAIB,IBRF,IBRL,IBSIN,IBPTYPE,IBAPPTS,IBAPPTE,IBEXCEL,^TMP("IBCOMA",$JOB)
+4 ;IB*752/DTG var's for case insensitive
KILL IBRFU,IBRLU
+5 QUIT
+6 ;IBCOMA
