- 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 Jan 18, 2025@03:19:28 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