Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCOMA

IBCOMA.m

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