- IBCOMC2 ;ALB/CMS - IDENTIFY PT BY AGE WITH OR WITHOUT INSURANCE (CON'T) ;10-09-98
- ;;2.0;INTEGRATED BILLING;**103,153,516,528,743,752**;21-MAR-94;Build 20
- ;;Per VA Directive 6402, this routine should not be modified.
- Q
- 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 of the"
- W !,?5,"Patient's SSN.",!
- Q
- ;
- INSH ; Search criteria help Text
- W !!,?5,"Enter 1 to List patients covered by policies in Insurance Co. Name Range"
- W !,?15,"(i.e. Sort By: MEDICARE To: MEDICAREZZZ)"
- W !,?5,"Enter 2 to List patients covered by policies of the selected Insurance Co."
- W !,?15,"(User may enter up to six Companies.)"
- W !,?5,"Enter 3 to list patients with NO Coverage on file."
- Q
- ;
- AGEH ; Sort AGE help text
- W !!,?5,"Enter an Age Range to sort by (1-250). Or press return at the Start Age"
- W !,?5,"prompt to not include Age range in search criteria."
- Q
- ;
- HD ;Write Heading
- N IBX S IBPAGE=IBPAGE+1
- ;IB*752/DTG add full header in for excel
- ;I IBOUT="E" W:($E(IOST,1,2)["C-") ! W "Patient Name^SSN^Age^DOB^Means Test?^Inp/Out^Last Visit^Insurance Name^Reimb VA?^Plan Name" Q
- I IBOUT="E" D Q
- .I IBPAGE>1 Q
- .I $E(IOST,1,2)["C-" W !
- .W "Patients "_$S(IBSIN=3:"Without",1:"With")_" Insurance Report "_$$FMTE^XLFDT($$NOW^XLFDT,"Z"),!
- .W "Filtered by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL),! ;IB*752/DTG change sort to filter
- .W "Date Last Treated Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z"),!
- .I IBSIN=1 W "Insurance Company Range: "_$S(IBSINF="":"FIRST",1:IBSINF)_" to "_$S(IBSINL="zzzzzz":"LAST",1:IBSINL),!
- .I IBSIN=3 W "Patients with no Insurance on File",!
- .I IBAGEF W "Age Range: "_IBAGEF_" to "_IBAGEL,!
- .W "* - Patient Deceased",!
- .I IBSIN=2 D
- ..W "Active Policies with selected Insurance Companies:",!
- ..S IBX=0 F S IBX=$O(IBSIN(IBX)) Q:'IBX W $P(IBSIN(IBX),U,2),!
- .W "Patient Name^SSN^Age^DOB^Means Test?^Inp/Out^Last Visit^Insurance Name^Reimb VA?^Plan Name"
- ;
- W @IOF,!,"Patients "_$S(IBSIN=3:"Without",1:"With")_" Insurance Report",?50,$$FMTE^XLFDT($$NOW^XLFDT,"Z"),?70," Page ",IBPAGE
- I IBPAGE=1 D
- .;IB*743/TAZ - Modified Range Choice for beginning
- .;W !,?5,"Sorted by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
- .W !,?5,"Filtered by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL) ;IB*752/DTG change sort to filter
- .W !,?5,"Date Last Treated Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z")
- .;IB*743/TAZ - Modified Range Choice for beginning
- .;I IBSIN=1 W !,?5,"Insurance Company Range: "_$S(IBSINF="A":"FIRST",1:IBSINF)_" to "_$S(IBSINL="zzzzzz":"LAST",1:IBSINL)
- .I IBSIN=1 W !,?5,"Insurance Company Range: "_$S(IBSINF="":"FIRST",1:IBSINF)_" to "_$S(IBSINL="zzzzzz":"LAST",1:IBSINL)
- .I IBSIN=3 W !,?5,"Patients with no Insurance on File"
- .I IBAGEF W !,?5,"Age Range: "_IBAGEF_" to "_IBAGEL
- .W !,?5,"* - Patient Deceased"
- .;IB*752/DTG change from 6 insurances to many
- .;I IBSIN=2 W !,?5,"Active Policies with selected Insurance Companies:" F IBX=1:1:6 Q:'$D(IBSIN(IBX)) W !,?10,$P(IBSIN(IBX),U,2)
- .I IBSIN=2 D
- ..W !,?5,"Active Policies with selected Insurance Companies:"
- ..S IBX=0 F S IBX=$O(IBSIN(IBX)) Q:'IBX W !,?10,$P(IBSIN(IBX),U,2)
- W !!?58,"Means",!,"Patient Name (SSN)",?39,"Age",?44,"DOB",?58,"Test?",?70,"Last Visit"
- W ! F IBX=1:1:80 W "="
- Q
- ;
- WRT ;Write data lines
- N IBCDA,IBDA,IBDFN,IBINS,IBNA,IBPOL,IBPT,X,Y S IBQUIT=0
- S IBNA="" F S IBNA=$O(^TMP("IBCOMC",$J,1,IBNA)) Q:(IBNA="")!(IBQUIT=1) D
- .S IBDFN=0 F S IBDFN=$O(^TMP("IBCOMC",$J,1,IBNA,IBDFN)) Q:('IBDFN)!(IBQUIT=1) D
- ..S IBPT=$G(^TMP("IBCOMC",$J,1,IBNA,IBDFN))
- ..;
- ..I ($Y+5)>IOSL,(IBOUT="R") D I IBQUIT=1 Q
- ...D ASK I IBQUIT=1 Q
- ...D HD
- ..;
- ..; Excel Output
- ..I IBOUT="E" W !,$P(IBPT,U,1)_U_$TR($TR($P(IBPT,U,2),"(",""),")","")_U_$P(IBPT,U,3,5)_U_$P($P(IBPT,U,6)," ")_U_$P($P(IBPT,U,6)," ",2)
- ..; Report Output
- ..I IBOUT="R" W !!,$E($P(IBPT,U,1),1,30)_" "_$P(IBPT,U,2),?39,$P(IBPT,U,3),?44,$P(IBPT,U,4),?58,$P(IBPT,U,5),?65,$P(IBPT,U,6)
- ..;
- ..S IBDA=0 F S IBDA=$O(^TMP("IBCOMC",$J,1,IBNA,IBDFN,IBDA)) Q:('IBDA)!(IBQUIT=1) D
- ...S IBINS=$G(^TMP("IBCOMC",$J,1,IBNA,IBDFN,IBDA))
- ...I IBSIN=3 W:IBOUT="R" ! W:IBOUT="E" U W IBINS Q
- ...; Excel Output
- ...I IBOUT="E" W U_$P(IBINS,U,1,3)
- ...; Report Output
- ...I IBOUT="R" W !?3,$E($P(IBINS,U,1),1,30),?35,"Reimb VA? ",$P(IBINS,U,2),!?4,"Plan Name: ",$E($P(IBINS,U,3),1,65)
- ...;
- ;I 'IBQUIT D ASK ;IB*752/DTG - remove the extra pause
- Q
- ;
- ASK ; Ask to Continue with display
- ; also called from IBCNSUR1 and IBCOMA1
- I $E(IOST,1,2)'["C-" Q
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- S DIR(0)="E" D ^DIR
- I ($D(DIRUT))!($D(DUOUT)) S IBQUIT=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCOMC2 5118 printed Jan 18, 2025@03:19:32 Page 2
- IBCOMC2 ;ALB/CMS - IDENTIFY PT BY AGE WITH OR WITHOUT INSURANCE (CON'T) ;10-09-98
- +1 ;;2.0;INTEGRATED BILLING;**103,153,516,528,743,752**;21-MAR-94;Build 20
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 QUIT
- 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 of the"
- +4 WRITE !,?5,"Patient's SSN.",!
- +5 QUIT
- +6 ;
- INSH ; Search criteria help Text
- +1 WRITE !!,?5,"Enter 1 to List patients covered by policies in Insurance Co. Name Range"
- +2 WRITE !,?15,"(i.e. Sort By: MEDICARE To: MEDICAREZZZ)"
- +3 WRITE !,?5,"Enter 2 to List patients covered by policies of the selected Insurance Co."
- +4 WRITE !,?15,"(User may enter up to six Companies.)"
- +5 WRITE !,?5,"Enter 3 to list patients with NO Coverage on file."
- +6 QUIT
- +7 ;
- AGEH ; Sort AGE help text
- +1 WRITE !!,?5,"Enter an Age Range to sort by (1-250). Or press return at the Start Age"
- +2 WRITE !,?5,"prompt to not include Age range in search criteria."
- +3 QUIT
- +4 ;
- HD ;Write Heading
- +1 NEW IBX
- SET IBPAGE=IBPAGE+1
- +2 ;IB*752/DTG add full header in for excel
- +3 ;I IBOUT="E" W:($E(IOST,1,2)["C-") ! W "Patient Name^SSN^Age^DOB^Means Test?^Inp/Out^Last Visit^Insurance Name^Reimb VA?^Plan Name" Q
- +4 IF IBOUT="E"
- Begin DoDot:1
- +5 IF IBPAGE>1
- QUIT
- +6 IF $EXTRACT(IOST,1,2)["C-"
- WRITE !
- +7 WRITE "Patients "_$SELECT(IBSIN=3:"Without",1:"With")_" Insurance Report "_$$FMTE^XLFDT($$NOW^XLFDT,"Z"),!
- +8 ;IB*752/DTG change sort to filter
- WRITE "Filtered by: "_$SELECT(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$SELECT(IBRF="":"FIRST",1:IBRF)_" to "_$SELECT(IBRL="zzzzzz":"LAST",1:IBRL),!
- +9 WRITE "Date Last Treated Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z"),!
- +10 IF IBSIN=1
- WRITE "Insurance Company Range: "_$SELECT(IBSINF="":"FIRST",1:IBSINF)_" to "_$SELECT(IBSINL="zzzzzz":"LAST",1:IBSINL),!
- +11 IF IBSIN=3
- WRITE "Patients with no Insurance on File",!
- +12 IF IBAGEF
- WRITE "Age Range: "_IBAGEF_" to "_IBAGEL,!
- +13 WRITE "* - Patient Deceased",!
- +14 IF IBSIN=2
- Begin DoDot:2
- +15 WRITE "Active Policies with selected Insurance Companies:",!
- +16 SET IBX=0
- FOR
- SET IBX=$ORDER(IBSIN(IBX))
- if 'IBX
- QUIT
- WRITE $PIECE(IBSIN(IBX),U,2),!
- End DoDot:2
- +17 WRITE "Patient Name^SSN^Age^DOB^Means Test?^Inp/Out^Last Visit^Insurance Name^Reimb VA?^Plan Name"
- End DoDot:1
- QUIT
- +18 ;
- +19 WRITE @IOF,!,"Patients "_$SELECT(IBSIN=3:"Without",1:"With")_" Insurance Report",?50,$$FMTE^XLFDT($$NOW^XLFDT,"Z"),?70," Page ",IBPAGE
- +20 IF IBPAGE=1
- Begin DoDot:1
- +21 ;IB*743/TAZ - Modified Range Choice for beginning
- +22 ;W !,?5,"Sorted by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
- +23 ;IB*752/DTG change sort to filter
- WRITE !,?5,"Filtered by: "_$SELECT(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$SELECT(IBRF="":"FIRST",1:IBRF)_" to "_$SELECT(IBRL="zzzzzz":"LAST",1:IBRL)
- +24 WRITE !,?5,"Date Last Treated Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z")
- +25 ;IB*743/TAZ - Modified Range Choice for beginning
- +26 ;I IBSIN=1 W !,?5,"Insurance Company Range: "_$S(IBSINF="A":"FIRST",1:IBSINF)_" to "_$S(IBSINL="zzzzzz":"LAST",1:IBSINL)
- +27 IF IBSIN=1
- WRITE !,?5,"Insurance Company Range: "_$SELECT(IBSINF="":"FIRST",1:IBSINF)_" to "_$SELECT(IBSINL="zzzzzz":"LAST",1:IBSINL)
- +28 IF IBSIN=3
- WRITE !,?5,"Patients with no Insurance on File"
- +29 IF IBAGEF
- WRITE !,?5,"Age Range: "_IBAGEF_" to "_IBAGEL
- +30 WRITE !,?5,"* - Patient Deceased"
- +31 ;IB*752/DTG change from 6 insurances to many
- +32 ;I IBSIN=2 W !,?5,"Active Policies with selected Insurance Companies:" F IBX=1:1:6 Q:'$D(IBSIN(IBX)) W !,?10,$P(IBSIN(IBX),U,2)
- +33 IF IBSIN=2
- Begin DoDot:2
- +34 WRITE !,?5,"Active Policies with selected Insurance Companies:"
- +35 SET IBX=0
- FOR
- SET IBX=$ORDER(IBSIN(IBX))
- if 'IBX
- QUIT
- WRITE !,?10,$PIECE(IBSIN(IBX),U,2)
- End DoDot:2
- End DoDot:1
- +36 WRITE !!?58,"Means",!,"Patient Name (SSN)",?39,"Age",?44,"DOB",?58,"Test?",?70,"Last Visit"
- +37 WRITE !
- FOR IBX=1:1:80
- WRITE "="
- +38 QUIT
- +39 ;
- WRT ;Write data lines
- +1 NEW IBCDA,IBDA,IBDFN,IBINS,IBNA,IBPOL,IBPT,X,Y
- SET IBQUIT=0
- +2 SET IBNA=""
- FOR
- SET IBNA=$ORDER(^TMP("IBCOMC",$JOB,1,IBNA))
- if (IBNA="")!(IBQUIT=1)
- QUIT
- Begin DoDot:1
- +3 SET IBDFN=0
- FOR
- SET IBDFN=$ORDER(^TMP("IBCOMC",$JOB,1,IBNA,IBDFN))
- if ('IBDFN)!(IBQUIT=1)
- QUIT
- Begin DoDot:2
- +4 SET IBPT=$GET(^TMP("IBCOMC",$JOB,1,IBNA,IBDFN))
- +5 ;
- +6 IF ($Y+5)>IOSL
- IF (IBOUT="R")
- Begin DoDot:3
- +7 DO ASK
- IF IBQUIT=1
- QUIT
- +8 DO HD
- End DoDot:3
- IF IBQUIT=1
- QUIT
- +9 ;
- +10 ; Excel Output
- +11 IF IBOUT="E"
- WRITE !,$PIECE(IBPT,U,1)_U_$TRANSLATE($TRANSLATE($PIECE(IBPT,U,2),"(",""),")","")_U_$PIECE(IBPT,U,3,5)_U_$PIECE($PIECE(IBPT,U,6)," ")_U_$PIECE($PIECE(IBPT,U,6)," ",2)
- +12 ; Report Output
- +13 IF IBOUT="R"
- WRITE !!,$EXTRACT($PIECE(IBPT,U,1),1,30)_" "_$PIECE(IBPT,U,2),?39,$PIECE(IBPT,U,3),?44,$PIECE(IBPT,U,4),?58,$PIECE(IBPT,U,5),?65,$PIECE(IBPT,U,6)
- +14 ;
- +15 SET IBDA=0
- FOR
- SET IBDA=$ORDER(^TMP("IBCOMC",$JOB,1,IBNA,IBDFN,IBDA))
- if ('IBDA)!(IBQUIT=1)
- QUIT
- Begin DoDot:3
- +16 SET IBINS=$GET(^TMP("IBCOMC",$JOB,1,IBNA,IBDFN,IBDA))
- +17 IF IBSIN=3
- if IBOUT="R"
- WRITE !
- if IBOUT="E"
- WRITE U
- WRITE IBINS
- QUIT
- +18 ; Excel Output
- +19 IF IBOUT="E"
- WRITE U_$PIECE(IBINS,U,1,3)
- +20 ; Report Output
- +21 IF IBOUT="R"
- WRITE !?3,$EXTRACT($PIECE(IBINS,U,1),1,30),?35,"Reimb VA? ",$PIECE(IBINS,U,2),!?4,"Plan Name: ",$EXTRACT($PIECE(IBINS,U,3),1,65)
- +22 ;
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +23 ;I 'IBQUIT D ASK ;IB*752/DTG - remove the extra pause
- +24 QUIT
- +25 ;
- ASK ; Ask to Continue with display
- +1 ; also called from IBCNSUR1 and IBCOMA1
- +2 IF $EXTRACT(IOST,1,2)'["C-"
- QUIT
- +3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +4 SET DIR(0)="E"
- DO ^DIR
- +5 IF ($DATA(DIRUT))!($DATA(DUOUT))
- SET IBQUIT=1
- +6 QUIT