IBCNAU ;ALB/KML/AWC - USER EDIT REPORT (DRIVER) ;6-APRIL-2015
;;2.0;INTEGRATED BILLING;**528,664,737,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
;
;IB*737/CKB - references to 'eIV Payer' should be changed to 'Payer' in order
; to include 'IIU Payers'
Q
;
EN ;
;
; Prompt user to select report type, insurance companies, plans, payers
;
; Output from user selections:
;
; REPTYP=1 -- user selects report for only insurance companies/plans user edits
; REPTYP=2 -- user selects report for only payers user edits
; REPTYP=3 -- user selects report for both ins cos/plans and payers user edits
; ALLINS=0 -- user selects insurance companies
; ALLINS=1 -- run report for all insurance companies
; ALLPLANS=0 -- do not include Group Plans in the report
; ALLPLANS=1 -- include Group Plan in the report
; ALLPYRS=0 -- do not include Payers in the report
; ALLPYRS=1 -- include Payers in the report
; ALLUSERS=0 -- user ID selection (subset of users on the report that made edits)
; ALLUSERS=1 -- run report that shows edits from all users
N I,ALLINS,ALLPLANS,ALLPYRS,ALLUSERS,PLANS,QUIT,REPTYP,DATE,EXCEL,WIDTH ;/vd-IB*2*664 - Added ALLPYRS,REPTYP,WIDTH
N IBA,IBI,IBTMPINS ;IB*752/DTG added for case insensitive insurance lookup
S QUIT=0
;
;/vd-IB*2*664 - Replaced the following 4 lines with the code below:
;S ALLINS=$$SELI^IBCNAU1 I ALLINS<0 Q
;S ALLPLANS=$$SELP^IBCNAU1(ALLINS,.PLANS) I ALLPLANS<0 Q
;D GP(ALLINS,ALLPLANS,PLANS)
;S ALLUSERS=$$SELU^IBCNAU1 I ALLUSERS<0 Q
;
;/vd-IB*2*664 - Beginning of new code
S (ALLINS,ALLPLANS,ALLPYRS,ALLUSERS,PLANS)=0
K ^TMP("IBINC",$J),^TMP("IBPYR",$J),^TMP("IBUSER",$J),^TMP("IBPR",$J),^TMP("IBPR2",$J),^TMP($J)
S REPTYP=$$SELR^IBCNAU1 I REPTYP<0 Q ; Select the type of report
I REPTYP'=2 D ; report for ins cos/plans or both was selected
.S ALLINS=$$SELI^IBCNAU1 I ALLINS<0 Q
.S ALLPLANS=$$SELP^IBCNAU1(ALLINS,.PLANS) I ALLPLANS<0 Q
.D GP(ALLINS,ALLPLANS,PLANS)
;
I ALLINS<0!(ALLPLANS<0) Q
;IB*737/CKB - if REPTYP'=2 and 'Selected' Insurance Companies, however no Insurance
; Companies were selected by the user or the user entered '^', Quit
I REPTYP'=2 I ALLINS=0,'$D(^TMP("IBINC",$J)) Q
;
I REPTYP'=1 D ; report for payers or both was selected
.S ALLPYRS=$$SELPY^IBCNAU1 ; Check on All or Selected Payers
.I ALLPYRS<0 Q
.D GPYR^IBCNAU1(ALLPYRS)
;
I ALLINS<0!(ALLPLANS<0)!(ALLPYRS<0) Q ; Nothing to report so quit
;IB*737/CKB - if REPTYP'=1 and 'Selected' Payers, however no Payers were
; selected by the user or the user entered '^', Quit
I REPTYP'=1 I ALLPYRS=0&'$D(^TMP("IBPYR",$J)) Q
S ALLUSERS=$$SELU^IBCNAU1 I ALLUSERS<0 Q
;/vd-IB*2*664 - End of new code
;
; obtain plans for selected insurance companies
;
D START(ALLUSERS,.DATE) I QUIT Q
;/vd-IB*2*664 - Replaced the following line of code.
;I '$D(^TMP("IBINC",$J)) W !!,"Nothing selected!" Q
NORPT I '$D(^TMP("IBINC",$J)),'$D(^TMP("IBPYR",$J)),'$D(^TMP("IBUSER",$J)) W !!,"Nothing selected!" D PAUSE^IBCNAU3 Q ; Nothing selected, so QUIT
I QUIT W !!,"Nothing selected!" D PAUSE^IBCNAU3 Q ;/vd - IB*2.0*664 - Added this line
;
DEVICE ; Ask user to select device
;
S EXCEL=$$GETTYP^IBCNAU1()
Q:EXCEL<0
S WIDTH=$S(+EXCEL:200,1:132) ;/vd-IB*2.0*664 - Instituted the variable WIDTH for the report headings length.
I 'EXCEL D
. W !!,"*** You will need a 132 column printer for this report. ***",!
E W !!,"To avoid undesired wrapping, please enter '0;256;999' at the 'DEVICE:' prompt."
; IB*737/DTG correct and reorder queuing of report
;N POP,%ZIS,ZTDESC,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ S %ZIS="QM" D ^%ZIS Q:POP
N ZTDESC,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ
;I $D(IO("Q")) D Q
;.S ZTRTN="EN^IBCNAU2",ZTDESC="User Edit Report"
;.;F I="^TMP(""IBINC"",$J,","^TMP(""IBUSER"",$J,","ALLUSERS","ALLINS","PLANS","ALLPLANS",DATE","EXCEL" S ZTSAVE(I)=""
;.;/vd-IB*2*664 - Above line replaced with the line below.
;.F I="^TMP(""IBINC"",$J,","^TMP(""IBUSER"",$J,","ALLUSERS","ALLINS","PLANS","ALLPLANS","ALLPYRS","DATE","EXCEL" S ZTSAVE(I)=""
;.D ^%ZTLOAD K IO("Q") D HOME^%ZIS
;.W !!,$S($D(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
;.K ZTSK,IO("Q")
F I="^TMP(""IBINC"",$J,","^TMP(""IBUSER"",$J,","ALLUSERS","ALLINS" S ZTSAVE(I)=""
F I="PLANS","ALLPLANS","ALLPYRS","DATE(","EXCEL","REPTYP","WIDTH" S ZTSAVE(I)=""
S ZTDESC="User Edit Report"
S ZTRTN="EN^IBCNAU2(ALLINS,ALLPLANS,PLANS,ALLPYRS,REPTYP,.DATE)"
D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"Q")
;
; this section is now being done by XUTMDDEVQ above
;
; -- compile and print report
;U IO D EN^IBCNAU2(ALLINS,ALLPLANS,PLANS,.DATE)
;/vd-IB*2*664 - Above line replaced with the line below.
;U IO D EN^IBCNAU2(ALLINS,ALLPLANS,PLANS,ALLPYRS,REPTYP,.DATE)
;K ^TMP("IBPYR",$J),^TMP("IBINC",$J),^TMP("IBUSER",$J),^TMP("IBPR",$J),^TMP("IBPR2",$J),^TMP($J)
I POP D
. K ^TMP("IBPYR",$J),^TMP("IBINC",$J),^TMP("IBUSER",$J),^TMP("IBPR",$J),^TMP("IBPR2",$J),^TMP($J)
. K ^TMP("IBPRINS",$J) ; IB*737/DTG to track which DIA(36,"B",INSIENS have been picked up
;
Q
;
START(ALLUSERS,DATE) ;
I 'ALLUSERS D USERS Q:QUIT
D GETDATE(.DATE) Q:QUIT
Q
;
GP(ALLINS,ALLPLANS,PLANS) ; Gather plans for all selected companies.
N A,B,C,IBIC,IBCNS,IBCT,IBOK,IBPN,IBSEL,VAUTI,VAUTNALL,VAUTNI,VAUTSTR,VAUTVB,IBAI,IBAIF,IBAPF,IBAPL,IBQUIT,DIC,IBTXT
S (IBCT,IBQUIT,IBAIF,IBAPF,IBAPL)=0,IBAI=1
K ^TMP("IBINC",$J)
;
; -- allow user to select insurance companies and select group plans
I 'ALLINS,'ALLPLANS,PLANS D G GPQ
. N IBINSCO
. ;IB*752/DTG start 1 of 3 change to case insensitive
. ;D INSCO^IBCNINSL(.IBINSCO) Q:Y<0
. K IBINSCO,IBTMPINS
. D INSOCAS^IBCNINSC(.IBTMPINS)
. I +IBTMPINS<1!($E(IBTMPINS,1)=U) S Y=-1 K IBTMPINS Q
. S IBI=0 F S IBI=$O(IBTMPINS(IBI)) Q:'IBI D
. . S IBA=$G(IBTMPINS(IBI)),IBA=$P(IBA,U,2) I IBA'="" S IBINSCO(IBI)=IBA
. S IBI=0,IBI=$O(IBINSCO(IBI)) I +IBI<1 S Y=-1 K IBTMPINS Q
. ;IB*752/DTG stop 1 of 3 change to case insensitive
. S IBCNS="" F S IBCNS=$O(IBINSCO(IBCNS)) Q:IBCNS="" D
. . S IBTXT=$E(IBINSCO(IBCNS),1,25) I IBTXT]"" S ^TMP("IBINC",$J,IBTXT,IBCNS)=""
. ;
. ; -- gather group plans for selected insurance companies
. S IBIC="" F S IBIC=$O(^TMP("IBINC",$J,IBIC)) Q:IBIC=""!IBQUIT D
. . S IBCNS="" F S IBCNS=$O(^TMP("IBINC",$J,IBIC,IBCNS)) Q:IBCNS=""!(IBQUIT) D
. . . S IBCT=IBCT+1
. . . I IBCT=1 W !,!
. . . E W !
. . . W "Insurance Company # "_IBCT_": "_IBIC
. . . D OK^IBCNSM3 I 'IBOK K ^TMP("IBINC",$J,IBIC,IBCNS) S ALLINS=0 Q
. . . W !," ...building a list of plans..."
. . . ;
. . . K IBSEL,^TMP($J,"IBSEL") D LKP^IBCNSU2(IBCNS,1,1,.IBSEL,0,IBAPF) Q:IBQUIT
. . . I '$O(^TMP($J,"IBSEL",0)) K ^TMP("IBINC",$J,IBIC,IBCNS) S ALLINS=0 Q
. . . ;
. . . ; - set plans into an array
. . . S IBPN=0 F S IBPN=$O(^TMP($J,"IBSEL",IBPN)) Q:'IBPN I +$$GET1^DIQ(355.3,IBPN,.11,"I")=IBAPF S ^TMP("IBINC",$J,IBIC,IBCNS,IBPN)=""
;
;
; -- allow user to select insurance companies and no group plans
I 'ALLINS,'ALLPLANS,'PLANS D G GPQ
. N IBINSCO
. ;IB*752/DTG start 2 of 3 change to case insensitive
. ;D INSCO^IBCNINSL(.IBINSCO) Q:Y<0
. K IBINSCO,IBTMPINS
. D INSOCAS^IBCNINSC(.IBTMPINS)
. I +IBTMPINS<1!($E(IBTMPINS,1)=U) S Y=-1 K IBTMPINS Q
. S IBI=0 F S IBI=$O(IBTMPINS(IBI)) Q:'IBI D
. . S IBA=$G(IBTMPINS(IBI)),IBA=$P(IBA,U,2) I IBA'="" S IBINSCO(IBI)=IBA
. S IBI=0,IBI=$O(IBINSCO(IBI)) I +IBI<1 S Y=-1 K IBTMPINS Q
. ;IB*752/DTG stop 2 of 3 change to case insensitive
. S IBCNS="" F S IBCNS=$O(IBINSCO(IBCNS)) Q:IBCNS="" S IBTXT=$E(IBINSCO(IBCNS),1,25) I IBTXT]"" S ^TMP("IBINC",$J,IBTXT,IBCNS)=""
. ;
;
; -- allow user to select insurance companies and and add all group plans
I 'ALLINS,ALLPLANS,PLANS D G GPQ
. N IBINSCO
. ;IB*752/DTG start 3 of 3 change to case insensitive
. ;D INSCO^IBCNINSL(.IBINSCO) Q:Y<0
. K IBINSCO,IBTMPINS
. D INSOCAS^IBCNINSC(.IBTMPINS)
. I +IBTMPINS<1!($E(IBTMPINS,1)=U) S Y=-1 K IBTMPINS Q
. S IBI=0 F S IBI=$O(IBTMPINS(IBI)) Q:'IBI D
. . S IBA=$G(IBTMPINS(IBI)),IBA=$P(IBA,U,2) I IBA'="" S IBINSCO(IBI)=IBA
. S IBI=0,IBI=$O(IBINSCO(IBI)) I +IBI<1 S Y=-1 K IBTMPINS Q
. ;IB*752/DTG stop 3 of 3 change to case insensitive
. S IBCNS="" F S IBCNS=$O(IBINSCO(IBCNS)) Q:IBCNS="" S IBTXT=$E(IBINSCO(IBCNS),1,25) I IBTXT]"" S ^TMP("IBINC",$J,IBTXT,IBCNS)="" D
. . S IBPN=0 F S IBPN=$O(^IBA(355.3,"B",IBCNS,IBPN)) Q:'IBPN I +$$GET1^DIQ(355.3,IBPN,.11,"I")=IBAPF S ^TMP("IBINC",$J,IBTXT,IBCNS,IBPN)=""
. ;
;
; - gather all companies and all group insurance plans
I ALLINS,ALLPLANS,PLANS D G GPQ
. F A=0:0 S A=$O(^IBA(355.3,"B",A)) Q:A'>0 D
. . F B=0:0 S B=$O(^IBA(355.3,"B",A,B)) Q:B'>0 D
. . . S C=$P($G(^IBA(355.3,B,0)),U) I C']"" Q
. . . I +$$GET1^DIQ(36,C,.05,"I")=IBAIF S IBTXT=$E($$GET1^DIQ(36,C,.01),1,25) I IBTXT]"" S ^TMP("IBINC",$J,IBTXT,C,B)=""
;
;
; - gather all companies - do not report group plans
I ALLINS,'ALLPLANS,'PLANS D
. F A=0:0 S A=$O(^IBA(355.3,"B",A)) Q:A'>0 D
. . F B=0:0 S B=$O(^IBA(355.3,"B",A,B)) Q:B'>0 D
. . . S C=$P($G(^IBA(355.3,B,0)),U) I C']"" Q
. . . I +$$GET1^DIQ(36,C,.05,"I")=IBAIF S IBTXT=$E($$GET1^DIQ(36,C,.01),1,25) I IBTXT]"" S ^TMP("IBINC",$J,IBTXT,C)=""
;
GPQ K IBUTI,^TMP($J,"IBSEL")
Q
;
USERS ; see only a selection of users who may have made edits
N USER,ARRAY,X
K ^TMP("IBUSER",$J)
; $$LOOKUP^XUSER - supported API - IA#2343
; upon success $$LOOKUP funtion returns string: DUZ^NEW PERSON NAME
F S USER=$$LOOKUP^XUSER Q:USER<0 S ^TMP("IBUSER",$J,$P(USER,U))=$P(USER,U,2)
; user purposely quits
I X="^" S QUIT=1 Q
; user didn't select any users and didn't purposely quit so list edits made by all users
I '$D(^TMP("IBUSER",$J)) S ALLUSERS=1
Q
;
GETDATE(DATE) ; show edits within a date range
; input - DATE is array holding the start and end date
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
GETDATE1 ;
S DIR(0)="D^::EX"
S DIR("A")="Start date"
W ! D ^DIR W ! I Y<0!$D(DIRUT) S QUIT=1 Q
I Y>DT W !,"FUTURE DATES ARE NOT ALLOWED." G GETDATE1 ;/vd - IB*2.0*664 - added this line.
S DATE("START")=Y
; End date
GETDATE2 ;
K DIR("A") S DIR("A")=" End date"
D ^DIR I $D(DIRUT) S QUIT=1 Q
I Y<DATE("START") W !," End Date must not precede the Start Date." G GETDATE1
I Y>DT W !,"FUTURE DATES ARE NOT ALLOWED." G GETDATE2 ;/vd - IB*2.0*664 - added this line.
S DATE("END")=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNAU 10537 printed Dec 13, 2024@02:13:41 Page 2
IBCNAU ;ALB/KML/AWC - USER EDIT REPORT (DRIVER) ;6-APRIL-2015
+1 ;;2.0;INTEGRATED BILLING;**528,664,737,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;IB*737/CKB - references to 'eIV Payer' should be changed to 'Payer' in order
+5 ; to include 'IIU Payers'
+6 QUIT
+7 ;
EN ;
+1 ;
+2 ; Prompt user to select report type, insurance companies, plans, payers
+3 ;
+4 ; Output from user selections:
+5 ;
+6 ; REPTYP=1 -- user selects report for only insurance companies/plans user edits
+7 ; REPTYP=2 -- user selects report for only payers user edits
+8 ; REPTYP=3 -- user selects report for both ins cos/plans and payers user edits
+9 ; ALLINS=0 -- user selects insurance companies
+10 ; ALLINS=1 -- run report for all insurance companies
+11 ; ALLPLANS=0 -- do not include Group Plans in the report
+12 ; ALLPLANS=1 -- include Group Plan in the report
+13 ; ALLPYRS=0 -- do not include Payers in the report
+14 ; ALLPYRS=1 -- include Payers in the report
+15 ; ALLUSERS=0 -- user ID selection (subset of users on the report that made edits)
+16 ; ALLUSERS=1 -- run report that shows edits from all users
+17 ;/vd-IB*2*664 - Added ALLPYRS,REPTYP,WIDTH
NEW I,ALLINS,ALLPLANS,ALLPYRS,ALLUSERS,PLANS,QUIT,REPTYP,DATE,EXCEL,WIDTH
+18 ;IB*752/DTG added for case insensitive insurance lookup
NEW IBA,IBI,IBTMPINS
+19 SET QUIT=0
+20 ;
+21 ;/vd-IB*2*664 - Replaced the following 4 lines with the code below:
+22 ;S ALLINS=$$SELI^IBCNAU1 I ALLINS<0 Q
+23 ;S ALLPLANS=$$SELP^IBCNAU1(ALLINS,.PLANS) I ALLPLANS<0 Q
+24 ;D GP(ALLINS,ALLPLANS,PLANS)
+25 ;S ALLUSERS=$$SELU^IBCNAU1 I ALLUSERS<0 Q
+26 ;
+27 ;/vd-IB*2*664 - Beginning of new code
+28 SET (ALLINS,ALLPLANS,ALLPYRS,ALLUSERS,PLANS)=0
+29 KILL ^TMP("IBINC",$JOB),^TMP("IBPYR",$JOB),^TMP("IBUSER",$JOB),^TMP("IBPR",$JOB),^TMP("IBPR2",$JOB),^TMP($JOB)
+30 ; Select the type of report
SET REPTYP=$$SELR^IBCNAU1
IF REPTYP<0
QUIT
+31 ; report for ins cos/plans or both was selected
IF REPTYP'=2
Begin DoDot:1
+32 SET ALLINS=$$SELI^IBCNAU1
IF ALLINS<0
QUIT
+33 SET ALLPLANS=$$SELP^IBCNAU1(ALLINS,.PLANS)
IF ALLPLANS<0
QUIT
+34 DO GP(ALLINS,ALLPLANS,PLANS)
End DoDot:1
+35 ;
+36 IF ALLINS<0!(ALLPLANS<0)
QUIT
+37 ;IB*737/CKB - if REPTYP'=2 and 'Selected' Insurance Companies, however no Insurance
+38 ; Companies were selected by the user or the user entered '^', Quit
+39 IF REPTYP'=2
IF ALLINS=0
IF '$DATA(^TMP("IBINC",$JOB))
QUIT
+40 ;
+41 ; report for payers or both was selected
IF REPTYP'=1
Begin DoDot:1
+42 ; Check on All or Selected Payers
SET ALLPYRS=$$SELPY^IBCNAU1
+43 IF ALLPYRS<0
QUIT
+44 DO GPYR^IBCNAU1(ALLPYRS)
End DoDot:1
+45 ;
+46 ; Nothing to report so quit
IF ALLINS<0!(ALLPLANS<0)!(ALLPYRS<0)
QUIT
+47 ;IB*737/CKB - if REPTYP'=1 and 'Selected' Payers, however no Payers were
+48 ; selected by the user or the user entered '^', Quit
+49 IF REPTYP'=1
IF ALLPYRS=0&'$DATA(^TMP("IBPYR",$JOB))
QUIT
+50 SET ALLUSERS=$$SELU^IBCNAU1
IF ALLUSERS<0
QUIT
+51 ;/vd-IB*2*664 - End of new code
+52 ;
+53 ; obtain plans for selected insurance companies
+54 ;
+55 DO START(ALLUSERS,.DATE)
IF QUIT
QUIT
+56 ;/vd-IB*2*664 - Replaced the following line of code.
+57 ;I '$D(^TMP("IBINC",$J)) W !!,"Nothing selected!" Q
NORPT ; Nothing selected, so QUIT
IF '$DATA(^TMP("IBINC",$JOB))
IF '$DATA(^TMP("IBPYR",$JOB))
IF '$DATA(^TMP("IBUSER",$JOB))
WRITE !!,"Nothing selected!"
DO PAUSE^IBCNAU3
QUIT
+1 ;/vd - IB*2.0*664 - Added this line
IF QUIT
WRITE !!,"Nothing selected!"
DO PAUSE^IBCNAU3
QUIT
+2 ;
DEVICE ; Ask user to select device
+1 ;
+2 SET EXCEL=$$GETTYP^IBCNAU1()
+3 if EXCEL<0
QUIT
+4 ;/vd-IB*2.0*664 - Instituted the variable WIDTH for the report headings length.
SET WIDTH=$SELECT(+EXCEL:200,1:132)
+5 IF 'EXCEL
Begin DoDot:1
+6 WRITE !!,"*** You will need a 132 column printer for this report. ***",!
End DoDot:1
+7 IF '$TEST
WRITE !!,"To avoid undesired wrapping, please enter '0;256;999' at the 'DEVICE:' prompt."
+8 ; IB*737/DTG correct and reorder queuing of report
+9 ;N POP,%ZIS,ZTDESC,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ S %ZIS="QM" D ^%ZIS Q:POP
+10 NEW ZTDESC,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ
+11 ;I $D(IO("Q")) D Q
+12 ;.S ZTRTN="EN^IBCNAU2",ZTDESC="User Edit Report"
+13 ;.;F I="^TMP(""IBINC"",$J,","^TMP(""IBUSER"",$J,","ALLUSERS","ALLINS","PLANS","ALLPLANS",DATE","EXCEL" S ZTSAVE(I)=""
+14 ;.;/vd-IB*2*664 - Above line replaced with the line below.
+15 ;.F I="^TMP(""IBINC"",$J,","^TMP(""IBUSER"",$J,","ALLUSERS","ALLINS","PLANS","ALLPLANS","ALLPYRS","DATE","EXCEL" S ZTSAVE(I)=""
+16 ;.D ^%ZTLOAD K IO("Q") D HOME^%ZIS
+17 ;.W !!,$S($D(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
+18 ;.K ZTSK,IO("Q")
+19 FOR I="^TMP(""IBINC"",$J,","^TMP(""IBUSER"",$J,","ALLUSERS","ALLINS"
SET ZTSAVE(I)=""
+20 FOR I="PLANS","ALLPLANS","ALLPYRS","DATE(","EXCEL","REPTYP","WIDTH"
SET ZTSAVE(I)=""
+21 SET ZTDESC="User Edit Report"
+22 SET ZTRTN="EN^IBCNAU2(ALLINS,ALLPLANS,PLANS,ALLPYRS,REPTYP,.DATE)"
+23 DO EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"Q")
+24 ;
+25 ; this section is now being done by XUTMDDEVQ above
+26 ;
+27 ; -- compile and print report
+28 ;U IO D EN^IBCNAU2(ALLINS,ALLPLANS,PLANS,.DATE)
+29 ;/vd-IB*2*664 - Above line replaced with the line below.
+30 ;U IO D EN^IBCNAU2(ALLINS,ALLPLANS,PLANS,ALLPYRS,REPTYP,.DATE)
+31 ;K ^TMP("IBPYR",$J),^TMP("IBINC",$J),^TMP("IBUSER",$J),^TMP("IBPR",$J),^TMP("IBPR2",$J),^TMP($J)
+32 IF POP
Begin DoDot:1
+33 KILL ^TMP("IBPYR",$JOB),^TMP("IBINC",$JOB),^TMP("IBUSER",$JOB),^TMP("IBPR",$JOB),^TMP("IBPR2",$JOB),^TMP($JOB)
+34 ; IB*737/DTG to track which DIA(36,"B",INSIENS have been picked up
KILL ^TMP("IBPRINS",$JOB)
End DoDot:1
+35 ;
+36 QUIT
+37 ;
START(ALLUSERS,DATE) ;
+1 IF 'ALLUSERS
DO USERS
if QUIT
QUIT
+2 DO GETDATE(.DATE)
if QUIT
QUIT
+3 QUIT
+4 ;
GP(ALLINS,ALLPLANS,PLANS) ; Gather plans for all selected companies.
+1 NEW A,B,C,IBIC,IBCNS,IBCT,IBOK,IBPN,IBSEL,VAUTI,VAUTNALL,VAUTNI,VAUTSTR,VAUTVB,IBAI,IBAIF,IBAPF,IBAPL,IBQUIT,DIC,IBTXT
+2 SET (IBCT,IBQUIT,IBAIF,IBAPF,IBAPL)=0
SET IBAI=1
+3 KILL ^TMP("IBINC",$JOB)
+4 ;
+5 ; -- allow user to select insurance companies and select group plans
+6 IF 'ALLINS
IF 'ALLPLANS
IF PLANS
Begin DoDot:1
+7 NEW IBINSCO
+8 ;IB*752/DTG start 1 of 3 change to case insensitive
+9 ;D INSCO^IBCNINSL(.IBINSCO) Q:Y<0
+10 KILL IBINSCO,IBTMPINS
+11 DO INSOCAS^IBCNINSC(.IBTMPINS)
+12 IF +IBTMPINS<1!($EXTRACT(IBTMPINS,1)=U)
SET Y=-1
KILL IBTMPINS
QUIT
+13 SET IBI=0
FOR
SET IBI=$ORDER(IBTMPINS(IBI))
if 'IBI
QUIT
Begin DoDot:2
+14 SET IBA=$GET(IBTMPINS(IBI))
SET IBA=$PIECE(IBA,U,2)
IF IBA'=""
SET IBINSCO(IBI)=IBA
End DoDot:2
+15 SET IBI=0
SET IBI=$ORDER(IBINSCO(IBI))
IF +IBI<1
SET Y=-1
KILL IBTMPINS
QUIT
+16 ;IB*752/DTG stop 1 of 3 change to case insensitive
+17 SET IBCNS=""
FOR
SET IBCNS=$ORDER(IBINSCO(IBCNS))
if IBCNS=""
QUIT
Begin DoDot:2
+18 SET IBTXT=$EXTRACT(IBINSCO(IBCNS),1,25)
IF IBTXT]""
SET ^TMP("IBINC",$JOB,IBTXT,IBCNS)=""
End DoDot:2
+19 ;
+20 ; -- gather group plans for selected insurance companies
+21 SET IBIC=""
FOR
SET IBIC=$ORDER(^TMP("IBINC",$JOB,IBIC))
if IBIC=""!IBQUIT
QUIT
Begin DoDot:2
+22 SET IBCNS=""
FOR
SET IBCNS=$ORDER(^TMP("IBINC",$JOB,IBIC,IBCNS))
if IBCNS=""!(IBQUIT)
QUIT
Begin DoDot:3
+23 SET IBCT=IBCT+1
+24 IF IBCT=1
WRITE !,!
+25 IF '$TEST
WRITE !
+26 WRITE "Insurance Company # "_IBCT_": "_IBIC
+27 DO OK^IBCNSM3
IF 'IBOK
KILL ^TMP("IBINC",$JOB,IBIC,IBCNS)
SET ALLINS=0
QUIT
+28 WRITE !," ...building a list of plans..."
+29 ;
+30 KILL IBSEL,^TMP($JOB,"IBSEL")
DO LKP^IBCNSU2(IBCNS,1,1,.IBSEL,0,IBAPF)
if IBQUIT
QUIT
+31 IF '$ORDER(^TMP($JOB,"IBSEL",0))
KILL ^TMP("IBINC",$JOB,IBIC,IBCNS)
SET ALLINS=0
QUIT
+32 ;
+33 ; - set plans into an array
+34 SET IBPN=0
FOR
SET IBPN=$ORDER(^TMP($JOB,"IBSEL",IBPN))
if 'IBPN
QUIT
IF +$$GET1^DIQ(355.3,IBPN,.11,"I")=IBAPF
SET ^TMP("IBINC",$JOB,IBIC,IBCNS,IBPN)=""
End DoDot:3
End DoDot:2
End DoDot:1
GOTO GPQ
+35 ;
+36 ;
+37 ; -- allow user to select insurance companies and no group plans
+38 IF 'ALLINS
IF 'ALLPLANS
IF 'PLANS
Begin DoDot:1
+39 NEW IBINSCO
+40 ;IB*752/DTG start 2 of 3 change to case insensitive
+41 ;D INSCO^IBCNINSL(.IBINSCO) Q:Y<0
+42 KILL IBINSCO,IBTMPINS
+43 DO INSOCAS^IBCNINSC(.IBTMPINS)
+44 IF +IBTMPINS<1!($EXTRACT(IBTMPINS,1)=U)
SET Y=-1
KILL IBTMPINS
QUIT
+45 SET IBI=0
FOR
SET IBI=$ORDER(IBTMPINS(IBI))
if 'IBI
QUIT
Begin DoDot:2
+46 SET IBA=$GET(IBTMPINS(IBI))
SET IBA=$PIECE(IBA,U,2)
IF IBA'=""
SET IBINSCO(IBI)=IBA
End DoDot:2
+47 SET IBI=0
SET IBI=$ORDER(IBINSCO(IBI))
IF +IBI<1
SET Y=-1
KILL IBTMPINS
QUIT
+48 ;IB*752/DTG stop 2 of 3 change to case insensitive
+49 SET IBCNS=""
FOR
SET IBCNS=$ORDER(IBINSCO(IBCNS))
if IBCNS=""
QUIT
SET IBTXT=$EXTRACT(IBINSCO(IBCNS),1,25)
IF IBTXT]""
SET ^TMP("IBINC",$JOB,IBTXT,IBCNS)=""
+50 ;
End DoDot:1
GOTO GPQ
+51 ;
+52 ; -- allow user to select insurance companies and and add all group plans
+53 IF 'ALLINS
IF ALLPLANS
IF PLANS
Begin DoDot:1
+54 NEW IBINSCO
+55 ;IB*752/DTG start 3 of 3 change to case insensitive
+56 ;D INSCO^IBCNINSL(.IBINSCO) Q:Y<0
+57 KILL IBINSCO,IBTMPINS
+58 DO INSOCAS^IBCNINSC(.IBTMPINS)
+59 IF +IBTMPINS<1!($EXTRACT(IBTMPINS,1)=U)
SET Y=-1
KILL IBTMPINS
QUIT
+60 SET IBI=0
FOR
SET IBI=$ORDER(IBTMPINS(IBI))
if 'IBI
QUIT
Begin DoDot:2
+61 SET IBA=$GET(IBTMPINS(IBI))
SET IBA=$PIECE(IBA,U,2)
IF IBA'=""
SET IBINSCO(IBI)=IBA
End DoDot:2
+62 SET IBI=0
SET IBI=$ORDER(IBINSCO(IBI))
IF +IBI<1
SET Y=-1
KILL IBTMPINS
QUIT
+63 ;IB*752/DTG stop 3 of 3 change to case insensitive
+64 SET IBCNS=""
FOR
SET IBCNS=$ORDER(IBINSCO(IBCNS))
if IBCNS=""
QUIT
SET IBTXT=$EXTRACT(IBINSCO(IBCNS),1,25)
IF IBTXT]""
SET ^TMP("IBINC",$JOB,IBTXT,IBCNS)=""
Begin DoDot:2
+65 SET IBPN=0
FOR
SET IBPN=$ORDER(^IBA(355.3,"B",IBCNS,IBPN))
if 'IBPN
QUIT
IF +$$GET1^DIQ(355.3,IBPN,.11,"I")=IBAPF
SET ^TMP("IBINC",$JOB,IBTXT,IBCNS,IBPN)=""
End DoDot:2
+66 ;
End DoDot:1
GOTO GPQ
+67 ;
+68 ; - gather all companies and all group insurance plans
+69 IF ALLINS
IF ALLPLANS
IF PLANS
Begin DoDot:1
+70 FOR A=0:0
SET A=$ORDER(^IBA(355.3,"B",A))
if A'>0
QUIT
Begin DoDot:2
+71 FOR B=0:0
SET B=$ORDER(^IBA(355.3,"B",A,B))
if B'>0
QUIT
Begin DoDot:3
+72 SET C=$PIECE($GET(^IBA(355.3,B,0)),U)
IF C']""
QUIT
+73 IF +$$GET1^DIQ(36,C,.05,"I")=IBAIF
SET IBTXT=$EXTRACT($$GET1^DIQ(36,C,.01),1,25)
IF IBTXT]""
SET ^TMP("IBINC",$JOB,IBTXT,C,B)=""
End DoDot:3
End DoDot:2
End DoDot:1
GOTO GPQ
+74 ;
+75 ;
+76 ; - gather all companies - do not report group plans
+77 IF ALLINS
IF 'ALLPLANS
IF 'PLANS
Begin DoDot:1
+78 FOR A=0:0
SET A=$ORDER(^IBA(355.3,"B",A))
if A'>0
QUIT
Begin DoDot:2
+79 FOR B=0:0
SET B=$ORDER(^IBA(355.3,"B",A,B))
if B'>0
QUIT
Begin DoDot:3
+80 SET C=$PIECE($GET(^IBA(355.3,B,0)),U)
IF C']""
QUIT
+81 IF +$$GET1^DIQ(36,C,.05,"I")=IBAIF
SET IBTXT=$EXTRACT($$GET1^DIQ(36,C,.01),1,25)
IF IBTXT]""
SET ^TMP("IBINC",$JOB,IBTXT,C)=""
End DoDot:3
End DoDot:2
End DoDot:1
+82 ;
GPQ KILL IBUTI,^TMP($JOB,"IBSEL")
+1 QUIT
+2 ;
USERS ; see only a selection of users who may have made edits
+1 NEW USER,ARRAY,X
+2 KILL ^TMP("IBUSER",$JOB)
+3 ; $$LOOKUP^XUSER - supported API - IA#2343
+4 ; upon success $$LOOKUP funtion returns string: DUZ^NEW PERSON NAME
+5 FOR
SET USER=$$LOOKUP^XUSER
if USER<0
QUIT
SET ^TMP("IBUSER",$JOB,$PIECE(USER,U))=$PIECE(USER,U,2)
+6 ; user purposely quits
+7 IF X="^"
SET QUIT=1
QUIT
+8 ; user didn't select any users and didn't purposely quit so list edits made by all users
+9 IF '$DATA(^TMP("IBUSER",$JOB))
SET ALLUSERS=1
+10 QUIT
+11 ;
GETDATE(DATE) ; show edits within a date range
+1 ; input - DATE is array holding the start and end date
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
GETDATE1 ;
+1 SET DIR(0)="D^::EX"
+2 SET DIR("A")="Start date"
+3 WRITE !
DO ^DIR
WRITE !
IF Y<0!$DATA(DIRUT)
SET QUIT=1
QUIT
+4 ;/vd - IB*2.0*664 - added this line.
IF Y>DT
WRITE !,"FUTURE DATES ARE NOT ALLOWED."
GOTO GETDATE1
+5 SET DATE("START")=Y
+6 ; End date
GETDATE2 ;
+1 KILL DIR("A")
SET DIR("A")=" End date"
+2 DO ^DIR
IF $DATA(DIRUT)
SET QUIT=1
QUIT
+3 IF Y<DATE("START")
WRITE !," End Date must not precede the Start Date."
GOTO GETDATE1
+4 ;/vd - IB*2.0*664 - added this line.
IF Y>DT
WRITE !,"FUTURE DATES ARE NOT ALLOWED."
GOTO GETDATE2
+5 SET DATE("END")=Y
+6 QUIT
