BARDMLP ;IHS/OIT/FCJ - 1 OF 2 ;DEBT MANAGEMENT PRINT LETTERS
;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23,24,27**;OCT 26, 2005;Build 12
;vc; Version BARDMLP.INT/BAR.1 Date 31-Oct-17 By User Location BAR$M
;vc; Component name INT.BARDMLP Routine name: BARDMLP
;New routine 5-12-2011 for Debt Letter Management
; Routine to print letters
; IHS/SD/POTT HEAT91638 NOV 2012 fixed pat DOB - BAR*1.8*23
; IHS/SD/POTT HEAT ;JAN 2013 ADDED SORTING OPTION -BAR*1.8*23
; IHS/SD/POTT HEAT ;APR 2013 FIXED BARPOC (INCL ERR LETTERS) - BAR*1.8*23
; IHS/SD/POTT HEAT ;MAY 2013 CHK / SET STATUS 'PAID' - BAR*1.8*23
; IHS/SD/POTT HEAT ;JUN 2013 RESOLVED '??' - BAR*1.8*23
; IHS/SD/POTT HEAT118656 BELCOURT: SKIP UNDEF ENTRY IN ^BARBL - BAR*1.8*24
; IHS/SD/POTT HEAT143490 12/04/14 FIX ADDRESSE'THE GUARDIAN...' IF INS. - BAR*1.8*24
; IHS/SD/POTT HEAT152452 2/10/14 CHK IF PAR/SAT FILE CORECTLY SET UP - BAR*1.8*24
; IHS/DIT/CPC New Medicare Card Initiative CR09275 11/3/2017 - BAR*1.8*27
ST ;
S BARRPT="L"
W @IOF
D TSTPRT
Q:$G(BARQ) ;P.OTT HEAT152452 2/10/2014
G:$D(DUOUT) XIT
D RRDT^BARDMU
;
101 K ^TMP("BARDME",$J)
K ^TMP("BARDM",$J)
K ^TMP("BARDMQN",$J)
;
D ETST
G:$G(BARQ) XIT2
G:$D(DUOUT) XIT
D VAR
D LET
D XIT
Q
XIT ;
I $D(IO("S")) S IOP="`"_IOS D ^%ZIS
E D ^%ZISC
XIT2 ;
;I DUZ=838 Q
K ^TMP("BARDME",$J)
K ^TMP("BARDM",$J)
K ^TMP("BARDMQN",$J) ;
K ERRT,ERRCT,AGE
Q
ETST ;ERROR TEST
;
S BAR2PRT=0 ;P.OTT SELECTION MOVED UP - BEFORE CALLING BARDMRE JULY 2013
S DIR(0)="SO^1:Print only letters w/o errors;2:Print only letters with errors;3:Print Both type of letters;4:Exit without printing"
S DIR("A")="Select letters to print: "
D ^DIR
K DIR
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BARQ=1 Q
I X="" G ETST1
I (X[U)!(X=4) S BARQ=1 Q
S BAR2PRT=+Y
;
S BARERRCT=0 ;#OF ER ENTRIES IN ^TMP('BARDME' (MULTIPLE REASONS FOR 1 LETTER!)
D CALC^BARDMRE(2) ;P.OTT : COUNT ONLY DUE PRINT ERR LETTERS
I BARERRCT>0 D PRINT^BARDMRE ;BARCT=#OF ERR LETTERS
Q:$G(BARQ)
Q:BARERRCT=0
ETST1 W !
Q
TSTPRT ;EP
D PAR^BARDMU ;GET PARAMETERS (INCL. BARPSRT)
Q:$G(BARQ) ;P.OTT HEAT152452 2/10/2014 BAR*1.8*24
S Y=$$DIR^XBDIR("Y","Do you wish to print a test letter","N")
Q:+Y<1
D ^%ZIS
Q:$D(DUOUT)
Q:POP
U IO
D VAR,VARSET
S BARMIN=2 ;NOT PAT 4/25/2014 BAR*1.8*24 FIX ADDRESSE'THE GUARDIAN...'
S CY=1,BARDACG="AUTNINS(",BARL="CYCLE 1"
S BARDM("INS_NM")="TEST INSURANCE"
S BARDM("INS_STR")="1234 STREET"
S BARDM("INS_CTY")="Portland"
S BARDM("INS_ST")=38
S BARDM("INS_ZP")=97204
S BARPAT="TEST PATIENT",BARBILN=1234,BARAMTO=0
S BARDM("DOS")=""
S BARPBDT="N"
S BARRPT="L"
S BARDTP=DT
S BARDOB="",BARNPIF="1234567890",BARNPIP="0987654321"
D PRINT^BARDMLP1
D ^%ZISC
G TSTPRT
Q
VAR ;SET LET VARIABLES
S BARLEN="" F I=1:1:30 S BARLEN=BARLEN_" "
S BARPAR1=^BAR(90052.06,BARPIEN,DUZ(2),18)
S BARAD1=$P(BARPAR1,U),BARAD2=$P(BARPAR1,U,2),BARCTY=$P(BARPAR1,U,3),BARST=$P(BARPAR1,U,4),BARZP=$P(BARPAR1,U,5),BARPH=$P(BARPAR1,U,6)
S BARPMX=$P(BARPAR1,U,8),BARMRGT=$P(BARPAR1,U,9),BARMRGL=$P(BARPAR1,U,10)
S BARSG=$P(BARPAR,U,13),BARSG1=$P(BARPAR,U,14),BARSG2=$P(BARPAR,U,15)
S C=1 F I=5:2:11 S BARPCP(C)=$P(BARPAR,U,I),C=C+1
S BARNPI=$P(BARPAR,3),BARLDOB=$P(BARPAR,4)
S:BARMRGT="" BARMRGT=5
S:BARMRGL="" BARMRGL=3
S BARFAC=$$VAL^XBDIQ1(9999999.06,DUZ(2),.01)
K BARPAR,BARPAR1
Q
VARSET ;RESET VARS
S BARMIN=0 ;BAR*1.8*24
S (BARDM("INS"),BARDM("MEMBER"),BARDM("POL_HOLDER_IEN"),BARDM("POL_HOLDER"),BARDM("POL_NUM"),BARDM("POL_DOB"),BARDM("INS_TX"))=""
Q
LET ;
;
K ^TMP($J,"BARDM")
NEW BARSORT,BAROK1,BAROK2,BARNOK1,BARNOK2
S CY=0,BARCT=0,BARQ=0
S BARTOT=0 ;
S BAROK1=0,BARNOK1=0 ;P.OTT (TOT)
S BAROK2=0,BARNOK2=0 ;P.OTT (ACTUAL COUNTS LIMITED BY MAX PRT#)
F BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4" D Q:BARQ
. S CY=CY+1
. S BARDM=0 F S BARDM=$O(^BARDM(DUZ(2),"S","Q",BARCYCLE,BARDM)) Q:BARDM'?1N.N D Q:BARQ
.. Q:$P(^BARDM(DUZ(2),BARDM,0),U,2)'="A"
.. I BAR2PRT=1 I $D(^TMP("BARDME",$J,BARDM)) Q ;PRINT OK ONLY and this is an ERR letter
.. I BAR2PRT=2 I '$D(^TMP("BARDME",$J,BARDM)) Q ;PRINT ERR ONLY and this is not an ERR letter
.. S BARDMC=0,BARDM("DOS")=""
.. F S BARDMC=$O(^BARDM(DUZ(2),"S","Q",BARCYCLE,BARDM,BARDMC)) Q:BARDMC'?1N.N D Q:BARQ
... I CY'=1 D CYDAY^BARDMRU I BARLQ=0 QUIT
... S X=$P(^BARDM(DUZ(2),BARDM,100,BARDMC,0),U,6),X2="2$" D COMMA^%DTC S BARAMTO="$"_$P(X,"$",2)
... S BARBIEN=$P(^BARDM(DUZ(2),BARDM,0),U)
... I '$D(^BARBL(DUZ(2),BARBIEN,0)) D Q ;HEAT118656 BELCOURT P.OTT
.... I $P($G(^VA(200,DUZ,0)),U,4)'="@" Q
.... W !,"MISSING DATA IN ^BARBL(",DUZ(2),",",BARBIEN
... S BARBILN=$$VAL^XBDIQ1(90053.05,BARDM,.01)
... S BARDAC=$P(^BARBL(DUZ(2),BARBIEN,0),U,3),BARDBDT=$P(^(0),U,7),BARD3P=$P(^(0),U,17)
... S BARD3PD=$P($G(^BARBL(DUZ(2),BARBIEN,0)),U,22)
... I '$D(^ABMDBILL(BARD3PD,BARD3P)) QUIT ;DUPLICATE BILL / NONEX CLAIM #
... S BARDMINS=$P($G(^ABMDBILL(BARD3PD,BARD3P,0)),U,8)
... S BARDM("DOS")=$$VAL^XBDIQ1(90050.01,BARBIEN,102)
... S BARNPIF=$P($$NPI^XUSNPI("Organization_ID",DUZ(2)),U)
... S BARNPIP=$S(+$$GET1^DIQ(90050.01,BARBIEN,113,"I")'=0:$P($$NPI^XUSNPI("Individual_ID",$$GET1^DIQ(90050.01,BARBIEN,113,"I")),U),1:"")
... I $P(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0 D Q ;P.OTT
.... W !,"Bill status of ",$P(^BARBL(DUZ(2),BARBIEN,0),U,1)," changed. Flagging DL as PAID."
.... D PAID(BARDM,BARDMC) Q
... D INSTYP^BARDMU
... S BARDI=$$VAL^XBDIQ1(90050.02,BARDAC,.01)
... I '$D(BARDINS(BARDI))&'$D(BARDINS(BARDITY)) D Q ;not insurer type or insurer we are looking for
... D POLCHK
... S BARTOT=BARTOT+1
... I $D(^TMP("BARDME",$J,BARDM)) S BARNOK1=BARNOK1+1
... I '$D(^TMP("BARDME",$J,BARDM)) S BAROK1=BAROK1+1
... I BARCT<BARPMX D ;?????DO WE NEED THIS??
.... I $D(^TMP("BARDME",$J,BARDM)) S BARNOK2=BARNOK2+1
.... I '$D(^TMP("BARDME",$J,BARDM)) S BAROK2=BAROK2+1
.... S BARCT=BARCT+1
.... I BARPSRT="" S ^TMP("BARDM",$J,"PRT",BARCYCLE,BARDMINS,BARDM,BARDMC)=""
.... I $E(BARPSRT)="P" D ;POLICYHOLDER,CYCLE,INS
..... S BARSORT=BARDM("POL_HOLDER") I BARSORT="" S BARSORT=" "
..... S ^TMP("BARDM",$J,"POLHNAME",BARSORT,BARCYCLE,BARDMINS,BARDM,BARDMC)=""
.... I $E(BARPSRT)="I" D ;INSNAME,CYCLE
..... S BARSORT=BARDM("INS_NM") I BARSORT="" S BARSORT=" "
..... S ^TMP("BARDM",$J,"INSNAME",BARSORT,BARCYCLE,BARDMINS,BARDM,BARDMC)=""
.... I $E(BARPSRT)="C" D ;CYCLE;INS,POLICYHOLDER
..... S BARSORT1=BARDM("INS_NM") I BARSORT1="" S BARSORT1=" "
..... S BARSORT2=BARDM("POL_HOLDER") I BARSORT2="" S BARSORT2=" "
..... S ^TMP("BARDM",$J,"CYCLE",BARCYCLE,BARSORT1,BARDMINS,BARSORT2,BARDM,BARDMC)=""
.... S ^TMP("BARDMQN",$J,BARCYCLE,BARDM,BARDMC)=BARDMINS ;for BARDMRQN report (after printing) ;
D SUMMARY
I BARQ QUIT ;DISPLAY SUMMARY OF LETTERS TO BE PRINTED ;
D ^%ZIS ;--->SELECT PRINTER
Q:POP
U IO
;SORT BY: <NIL> P(OLICY HOLDER) I(INSURANCE NAME)
IF BARPSRT="" D SORT0
IF $E(BARPSRT)="P" D SORT1
IF $E(BARPSRT)="I" D SORT2
IF $E(BARPSRT)="C" D SORT3
D ^%ZISC ;CLOSE PRINTER
;--------TERMINAL IO ----------------------
D Q:Y<1
. S Y=$$DIR^XBDIR("Y","Do you wish to display the print report","Y")
. I +Y<1 Q
. D ^BARDMRQN ;DISPLAY PRINT REPORT
. K DIR S (X,Y)=""
. S DIR(0)="E"
. S DIR("A")="Hit ENTER to continue"
. D ^DIR
. K DIR
Q
SORT0 S CY=0
F BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4" D
. S CY=CY+1,BARDMINS="" F S BARDMINS=$O(^TMP("BARDM",$J,"PRT",BARCYCLE,BARDMINS)) Q:'BARDMINS D
. . S BARDM=0 F S BARDM=$O(^TMP("BARDM",$J,"PRT",BARCYCLE,BARDMINS,BARDM)) Q:'BARDM D
. . .S BARDMC=0 F S BARDMC=$O(^TMP("BARDM",$J,"PRT",BARCYCLE,BARDMINS,BARDM,BARDMC)) Q:'BARDMC D ONEDM
Q
SORT1 ;
S BARSORT="" F S BARSORT=$O(^TMP("BARDM",$J,"POLHNAME",BARSORT)) Q:BARSORT="" D
. S CY=0 F BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4" D
. . S CY=CY+1,BARDMINS="" F S BARDMINS=$O(^TMP("BARDM",$J,"POLHNAME",BARSORT,BARCYCLE,BARDMINS)) Q:'BARDMINS D
. . . S BARDM=0 F S BARDM=$O(^TMP("BARDM",$J,"POLHNAME",BARSORT,BARCYCLE,BARDMINS,BARDM)) Q:'BARDM D
. . . . S BARDMC=0 F S BARDMC=$O(^TMP("BARDM",$J,"POLHNAME",BARSORT,BARCYCLE,BARDMINS,BARDM,BARDMC)) Q:'BARDMC D ONEDM
Q
SORT2 ;
S BARSORT="" F S BARSORT=$O(^TMP("BARDM",$J,"INSNAME",BARSORT)) Q:BARSORT="" D
. S CY=0 F BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4" D
. . S CY=CY+1,BARDMINS="" F S BARDMINS=$O(^TMP("BARDM",$J,"INSNAME",BARSORT,BARCYCLE,BARDMINS)) Q:'BARDMINS D
. . . S BARDM=0 F S BARDM=$O(^TMP("BARDM",$J,"INSNAME",BARSORT,BARCYCLE,BARDMINS,BARDM)) Q:'BARDM D
. . . . S BARDMC=0 F S BARDMC=$O(^TMP("BARDM",$J,"INSNAME",BARSORT,BARCYCLE,BARDMINS,BARDM,BARDMC)) Q:'BARDMC D ONEDM
Q
SORT3 S CY=0
F BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4" D
. S CY=CY+1,BARSORT1="" F S BARSORT1=$O(^TMP("BARDM",$J,"CYCLE",BARCYCLE,BARSORT1)) Q:BARSORT1="" D
. . S BARDMINS="" F S BARDMINS=$O(^TMP("BARDM",$J,"CYCLE",BARCYCLE,BARSORT1,BARDMINS)) Q:'BARDMINS D
. . . S BARSORT2="" F S BARSORT2=$O(^TMP("BARDM",$J,"CYCLE",BARCYCLE,BARSORT1,BARDMINS,BARSORT2)) Q:BARSORT2="" D
. . . . S BARDM=0 F S BARDM=$O(^TMP("BARDM",$J,"CYCLE",BARCYCLE,BARSORT1,BARDMINS,BARSORT2,BARDM)) Q:'BARDM D
. . . . . S BARDMC=0 F S BARDMC=$O(^TMP("BARDM",$J,"CYCLE",BARCYCLE,BARSORT1,BARDMINS,BARSORT2,BARDM,BARDMC)) Q:'BARDMC D ONEDM
Q
ONEDM ;
S BARDM("DOS")=""
S X=$P(^BARDM(DUZ(2),BARDM,100,BARDMC,0),U,6),X2="2$" D COMMA^%DTC S BARAMTO="$"_$P(X,"$",2)
S BARBIEN=$P(^BARDM(DUZ(2),BARDM,0),U)
S BARBILN=$$VAL^XBDIQ1(90053.05,BARDM,.01)
S BARDAC=$P(^BARBL(DUZ(2),BARBIEN,0),U,3),BARDBDT=$P(^(0),U,7),BARD3P=$P(^(0),U,17)
S BARD3PD=$P($G(^BARBL(DUZ(2),BARBIEN,0)),U,22)
S BARDM("DOS")=$$VAL^XBDIQ1(90050.01,BARBIEN,102)
S BARDOB=$$GET1^DIQ(2,BARDM("PAT_IEN"),".03","E") ;P.OTT
S BARNPIF=$P($$NPI^XUSNPI("Organization_ID",DUZ(2)),U)
S BARNPIP=$S(+$$GET1^DIQ(90050.01,BARBIEN,113,"I")'=0:$P($$NPI^XUSNPI("Individual_ID",$$GET1^DIQ(90050.01,BARBIEN,113,"I")),U),1:"")
D INSTYP^BARDMU
S BARDI=$$VAL^XBDIQ1(90050.02,BARDAC,.01)
I $P(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0 Q
D POLCHK
D PRINT^BARDMLP1
D CYUP
D LGUP
Q
POLCHK ;TEST FOR POLICY NO, POLICY HOLDER AND POLICY HOLDER DOB
S BARMIN=0 ;BAR*1.8*24
I BARDACG'="VA(" D
. S BARDM("PAT_IEN")=$P(^BARBL(DUZ(2),BARBIEN,1),U)
. S BARHRN=$P($G(^AUPNPAT(BARDM("PAT_IEN"),41,DUZ(2),0)),U,2)
. S BARPAT=$P(^DPT(BARDM("PAT_IEN"),0),U)
. S BARDOB=$$GET1^DIQ(2,BARDM("PAT_IEN"),".03","E")
D VARSET
;I BARDACG="AUTNINS(" D INSCHK ;OLD CODE
I BARDACG="AUTNINS(" D INSCHK S BARMIN=2 ;NOT A PAT 12/04/2013
I BARDACG="AUPNPAT(" D PATCHK
I BARDACG="VA(" D PERCHK
Q
INSCHK ;
S BARDM("INS")=^AUTNINS(BARDACI,0)
S BARDM("INS_NM")=$P(BARDM("INS"),U),BARDM("INS_STR")=$P(BARDM("INS"),U,2)
S BARDM("INS_CTY")=$P(BARDM("INS"),U,3),BARDM("INS_ST")=$P(BARDM("INS"),U,4)
S BARDM("INS_ZP")=$P(BARDM("INS"),U,5)
S BARDM("INS_TX")=$P(BARDM("INS"),U,11)
S BARTST=0
I $D(^ABMDBILL(BARD3PD,BARD3P,13,"B",BARDACI)) D
.S BARL="",BARL=$O(^ABMDBILL(BARD3PD,BARD3P,13,"B",BARDACI,BARL))
.D INSCHK1
Q:BARTST=1
S BARL=0 F S BARL=$O(^ABMDBILL(BARD3PD,BARD3P,13,BARL)) Q:BARL'?1N.N D Q:BARTST=1
.I $P(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,11)=BARDACI D INSCHK1
;end new code
Q
INSCHK1 ;
I $P(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,4)'="" D MCR^BARDMRE Q ;MCR^BARDMRE UPDATED FOR NMCI P27 IHS/DIT/CPC - 20171031
I $P(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,5)'="" D RR^BARDMRE Q ;RR^BARDMRE UPDATED FOR NMCI P27 IHS/DIT/CPC - 20171031
I $P(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,7)'="" D MCD^BARDMRE Q
I $P(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,8)'="" D PRVT^BARDMRE Q
;end new code
Q
PATCHK ;
S BARDM("INS_NM")=$P(BARPAT,",",2)_" "_$P(BARPAT,",",1)_" "_$P(BARPAT,",",3)
S BARDM("INS_STR")=$$VAL^XBDIQ1(2,BARDM("PAT_IEN"),.111)
S BARDM("INS_CTY")=$$VAL^XBDIQ1(2,BARDM("PAT_IEN"),.114)
;S BARDM("INS_ST")=$P(^DPT(BARDM("PAT_IEN"),.11),U,5)
S BARDM("INS_ST")=$P($G(^DPT(BARDM("PAT_IEN"),.11)),U,5)
S BARDM("INS_ZP")=$$VAL^XBDIQ1(2,BARDM("PAT_IEN"),.116)
;**CHECK AND SET BARMIN FOR MINOR OR NOT
S X1=$$VALI^XBDIQ1(90050.01,BARBIEN,102)
S X2=$$VALI^XBDIQ1(2,BARDM("PAT_IEN"),.03)
D ^%DTC S AGE=X\365.25 S:AGE>17 BARMIN=1
Q
PERCHK ;
S BARPAT=$$VAL^XBDIQ1(200,BARDACI,.01)
S BARDM("INS_NM")=$P(BARPAT,",",2)_" "_$P(BARPAT,",",1)_" "_$P(BARPAT,",",3)
S BARDM("INS_STR")=$$VAL^XBDIQ1(200,BARDACI,.111)
S BARDM("INS_CTY")=$$VAL^XBDIQ1(200,BARDACI,.114)
S BARDM("INS_ST")=$$VAL^XBDIQ1(200,BARDACI,.115)
S BARDM("INS_ZP")=$$VAL^XBDIQ1(200,BARDACI,.116)
Q
CYUP ;CYCLE UPDATE - SET LETTER STATUS AND QUE
S (DIC,DIE)="^BARDM(DUZ(2),"_BARDM_",100,",DA(1)=BARDM,DA=BARDMC
;S DR=".03///P;.04///"_DUZ_";.05///"_DT ;OLD CODE
S DR=".03////P;.04////"_DUZ_";.05////"_DT ;P.OTT FIX FOR YAKAMA '??'
D ^DIE
I CY=4 K DIE,DIC,DA,DR Q
;SET NEW LETTER STATUS AND QUE
S DIC(0)="L",X="CYCLE "_(CY+1)
D ^DIC
Q:+Y<0
S DA=+Y
S DR=".02///"_BARPCP(CY+1)_";.03///Q"_";.06///"_$P(^BARBL(DUZ(2),BARBIEN,0),U,15)
D ^DIE
K DIE,DIC,DA,DR
Q
LGADD ;ENTRY TO LOG FILE
D NOW^%DTC
S DIC(0)="L",DIC="^BARDMLG("_DUZ(2)_","
S X=%
D ^DIC
S BARLG=+Y
K DA
Q
LGCYL ;ADD CYCLE TO LOG FILE
S DA(1)=BARLG
S DIC(0)="L",DIC="^BARDMLG("_DUZ(2)_","_BARLG_",100,"
S DIC("P")=$P(^DD(90053.08,100,0),U,2)
S X=BARCYCLE
D ^DIC
S BARLGC=+Y
K DA
Q
LGUP ;ADD BILL TO LOG FILE
I '$D(BARLG) D LGADD ;GET NEW BATCH IEN
I $D(^BARDMLG(DUZ(2),BARLG,100,"B",BARCYCLE)) S BARLGC=$O(^BARDMLG(DUZ(2),BARLG,100,"B",BARCYCLE,"")) ;P.OTT 9/18/2013
I '$D(^BARDMLG(DUZ(2),BARLG,100,"B",BARCYCLE)) D LGCYL ;;GET NEW SUBFILE IEN
K DIC,DIE,DIR,X,Y,DA,DR
S DA(2)=BARLG
S DA(1)=BARLGC
S DIC(0)="L"
S DIC="^BARDMLG("_DUZ(2)_","_BARLG_",100,"_BARLGC_",10,"
S DIC("P")=$P(^DD(90053.09,10,0),U,2)
S X=BARBILN
D ^DIC
S $P(^BARDMLG(DUZ(2),BARLG,100,BARLGC,0),U,2)=$P(^BARDMLG(DUZ(2),BARLG,100,BARLGC,0),U,2)+1
Q
SUMMARY ;
S BARQ=0
D UNDL
W !," # of letters in queue : ",$J(BARTOT,6)
I BAR2PRT=2 W " with errors."
I BAR2PRT>2 W " incl. ",BARNOK1," letter(s) with errors."
I BARTOT W !,"# of letters that will be printed : ",$J(BAROK2+BARNOK2,6)
I BARTOT>BARPMX W !,"NOTE: According to the parameter setup only ",BARPMX," letters will be printed."
D UNDL
;
K DIR S (X,Y)=""
S DIR(0)="E"
I 'BARTOT S DIR("A")="There is nothing to print. Hit ENTER to quit"
I BARTOT S DIR("A")="Hit ENTER to continue printing, or ^ to quit (no printing)"
D ^DIR
K DIR
I X="^" S BARQ=1
I 'BARTOT S BARQ=1
QUIT
UNDL ;
NEW BARTMP
W ! F BARTMP=1:1:78 W "-"
Q
PAID(BARDM,BARDMC) ;SET THE PRINT QUEUED STATUS TO NOT QUEUED AND BILL STATUS TO PAID ;P.OTT
S DIE="^BARDM("_DUZ(2)_","_BARDM_",100,",DA(1)=BARDM,DA=BARDMC
S DR=".03///N"
D ^DIE
K DIE,DA,DR
S DIE="^BARDM("_DUZ(2)_",",DA=BARDM,DR=".02///P"
D ^DIE
K DIE,DA,DR
Q ;EOR--
BARDMLP ;IHS/OIT/FCJ - 1 OF 2 ;DEBT MANAGEMENT PRINT LETTERS
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23,24,27**;OCT 26, 2005;Build 12
+2 ;vc; Version BARDMLP.INT/BAR.1 Date 31-Oct-17 By User Location BAR$M
+3 ;vc; Component name INT.BARDMLP Routine name: BARDMLP
+4 ;New routine 5-12-2011 for Debt Letter Management
+5 ; Routine to print letters
+6 ; IHS/SD/POTT HEAT91638 NOV 2012 fixed pat DOB - BAR*1.8*23
+7 ; IHS/SD/POTT HEAT ;JAN 2013 ADDED SORTING OPTION -BAR*1.8*23
+8 ; IHS/SD/POTT HEAT ;APR 2013 FIXED BARPOC (INCL ERR LETTERS) - BAR*1.8*23
+9 ; IHS/SD/POTT HEAT ;MAY 2013 CHK / SET STATUS 'PAID' - BAR*1.8*23
+10 ; IHS/SD/POTT HEAT ;JUN 2013 RESOLVED '??' - BAR*1.8*23
+11 ; IHS/SD/POTT HEAT118656 BELCOURT: SKIP UNDEF ENTRY IN ^BARBL - BAR*1.8*24
+12 ; IHS/SD/POTT HEAT143490 12/04/14 FIX ADDRESSE'THE GUARDIAN...' IF INS. - BAR*1.8*24
+13 ; IHS/SD/POTT HEAT152452 2/10/14 CHK IF PAR/SAT FILE CORECTLY SET UP - BAR*1.8*24
+14 ; IHS/DIT/CPC New Medicare Card Initiative CR09275 11/3/2017 - BAR*1.8*27
ST ;
+1 SET BARRPT="L"
+2 WRITE @IOF
+3 DO TSTPRT
+4 ;P.OTT HEAT152452 2/10/2014
IF $GET(BARQ)
QUIT
+5 IF $DATA(DUOUT)
GOTO XIT
+6 DO RRDT^BARDMU
+7 ;
101 KILL ^TMP("BARDME",$JOB)
+1 KILL ^TMP("BARDM",$JOB)
+2 KILL ^TMP("BARDMQN",$JOB)
+3 ;
+4 DO ETST
+5 IF $GET(BARQ)
GOTO XIT2
+6 IF $DATA(DUOUT)
GOTO XIT
+7 DO VAR
+8 DO LET
+9 DO XIT
+10 QUIT
XIT ;
+1 IF $DATA(IO("S"))
SET IOP="`"_IOS
DO ^%ZIS
+2 IF '$TEST
DO ^%ZISC
XIT2 ;
+1 ;I DUZ=838 Q
+2 KILL ^TMP("BARDME",$JOB)
+3 KILL ^TMP("BARDM",$JOB)
+4 ;
KILL ^TMP("BARDMQN",$JOB)
+5 KILL ERRT,ERRCT,AGE
+6 QUIT
ETST ;ERROR TEST
+1 ;
+2 ;P.OTT SELECTION MOVED UP - BEFORE CALLING BARDMRE JULY 2013
SET BAR2PRT=0
+3 SET DIR(0)="SO^1:Print only letters w/o errors;2:Print only letters with errors;3:Print Both type of letters;4:Exit without printing"
+4 SET DIR("A")="Select letters to print: "
+5 DO ^DIR
+6 KILL DIR
+7 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET BARQ=1
QUIT
+8 IF X=""
GOTO ETST1
+9 IF (X[U)!(X=4)
SET BARQ=1
QUIT
+10 SET BAR2PRT=+Y
+11 ;
+12 ;#OF ER ENTRIES IN ^TMP('BARDME' (MULTIPLE REASONS FOR 1 LETTER!)
SET BARERRCT=0
+13 ;P.OTT : COUNT ONLY DUE PRINT ERR LETTERS
DO CALC^BARDMRE(2)
+14 ;BARCT=#OF ERR LETTERS
IF BARERRCT>0
DO PRINT^BARDMRE
+15 IF $GET(BARQ)
QUIT
+16 IF BARERRCT=0
QUIT
ETST1 WRITE !
+1 QUIT
TSTPRT ;EP
+1 ;GET PARAMETERS (INCL. BARPSRT)
DO PAR^BARDMU
+2 ;P.OTT HEAT152452 2/10/2014 BAR*1.8*24
IF $GET(BARQ)
QUIT
+3 SET Y=$$DIR^XBDIR("Y","Do you wish to print a test letter","N")
+4 IF +Y<1
QUIT
+5 DO ^%ZIS
+6 IF $DATA(DUOUT)
QUIT
+7 IF POP
QUIT
+8 USE IO
+9 DO VAR
DO VARSET
+10 ;NOT PAT 4/25/2014 BAR*1.8*24 FIX ADDRESSE'THE GUARDIAN...'
SET BARMIN=2
+11 SET CY=1
SET BARDACG="AUTNINS("
SET BARL="CYCLE 1"
+12 SET BARDM("INS_NM")="TEST INSURANCE"
+13 SET BARDM("INS_STR")="1234 STREET"
+14 SET BARDM("INS_CTY")="Portland"
+15 SET BARDM("INS_ST")=38
+16 SET BARDM("INS_ZP")=97204
+17 SET BARPAT="TEST PATIENT"
SET BARBILN=1234
SET BARAMTO=0
+18 SET BARDM("DOS")=""
+19 SET BARPBDT="N"
+20 SET BARRPT="L"
+21 SET BARDTP=DT
+22 SET BARDOB=""
SET BARNPIF="1234567890"
SET BARNPIP="0987654321"
+23 DO PRINT^BARDMLP1
+24 DO ^%ZISC
+25 GOTO TSTPRT
+26 QUIT
VAR ;SET LET VARIABLES
+1 SET BARLEN=""
FOR I=1:1:30
SET BARLEN=BARLEN_" "
+2 SET BARPAR1=^BAR(90052.06,BARPIEN,DUZ(2),18)
+3 SET BARAD1=$PIECE(BARPAR1,U)
SET BARAD2=$PIECE(BARPAR1,U,2)
SET BARCTY=$PIECE(BARPAR1,U,3)
SET BARST=$PIECE(BARPAR1,U,4)
SET BARZP=$PIECE(BARPAR1,U,5)
SET BARPH=$PIECE(BARPAR1,U,6)
+4 SET BARPMX=$PIECE(BARPAR1,U,8)
SET BARMRGT=$PIECE(BARPAR1,U,9)
SET BARMRGL=$PIECE(BARPAR1,U,10)
+5 SET BARSG=$PIECE(BARPAR,U,13)
SET BARSG1=$PIECE(BARPAR,U,14)
SET BARSG2=$PIECE(BARPAR,U,15)
+6 SET C=1
FOR I=5:2:11
SET BARPCP(C)=$PIECE(BARPAR,U,I)
SET C=C+1
+7 SET BARNPI=$PIECE(BARPAR,3)
SET BARLDOB=$PIECE(BARPAR,4)
+8 IF BARMRGT=""
SET BARMRGT=5
+9 IF BARMRGL=""
SET BARMRGL=3
+10 SET BARFAC=$$VAL^XBDIQ1(9999999.06,DUZ(2),.01)
+11 KILL BARPAR,BARPAR1
+12 QUIT
VARSET ;RESET VARS
+1 ;BAR*1.8*24
SET BARMIN=0
+2 SET (BARDM("INS"),BARDM("MEMBER"),BARDM("POL_HOLDER_IEN"),BARDM("POL_HOLDER"),BARDM("POL_NUM"),BARDM("POL_DOB"),BARDM("INS_TX"))=""
+3 QUIT
LET ;
+1 ;
+2 KILL ^TMP($JOB,"BARDM")
+3 NEW BARSORT,BAROK1,BAROK2,BARNOK1,BARNOK2
+4 SET CY=0
SET BARCT=0
SET BARQ=0
+5 ;
SET BARTOT=0
+6 ;P.OTT (TOT)
SET BAROK1=0
SET BARNOK1=0
+7 ;P.OTT (ACTUAL COUNTS LIMITED BY MAX PRT#)
SET BAROK2=0
SET BARNOK2=0
+8 FOR BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4"
Begin DoDot:1
+9 SET CY=CY+1
+10 SET BARDM=0
FOR
SET BARDM=$ORDER(^BARDM(DUZ(2),"S","Q",BARCYCLE,BARDM))
IF BARDM'?1N.N
QUIT
Begin DoDot:2
+11 IF $PIECE(^BARDM(DUZ(2),BARDM,0),U,2)'="A"
QUIT
+12 ;PRINT OK ONLY and this is an ERR letter
IF BAR2PRT=1
IF $DATA(^TMP("BARDME",$JOB,BARDM))
QUIT
+13 ;PRINT ERR ONLY and this is not an ERR letter
IF BAR2PRT=2
IF '$DATA(^TMP("BARDME",$JOB,BARDM))
QUIT
+14 SET BARDMC=0
SET BARDM("DOS")=""
+15 FOR
SET BARDMC=$ORDER(^BARDM(DUZ(2),"S","Q",BARCYCLE,BARDM,BARDMC))
IF BARDMC'?1N.N
QUIT
Begin DoDot:3
+16 IF CY'=1
DO CYDAY^BARDMRU
IF BARLQ=0
QUIT
+17 SET X=$PIECE(^BARDM(DUZ(2),BARDM,100,BARDMC,0),U,6)
SET X2="2$"
DO COMMA^%DTC
SET BARAMTO="$"_$PIECE(X,"$",2)
+18 SET BARBIEN=$PIECE(^BARDM(DUZ(2),BARDM,0),U)
+19 ;HEAT118656 BELCOURT P.OTT
IF '$DATA(^BARBL(DUZ(2),BARBIEN,0))
Begin DoDot:4
+20 IF $PIECE($GET(^VA(200,DUZ,0)),U,4)'="@"
QUIT
+21 WRITE !,"MISSING DATA IN ^BARBL(",DUZ(2),",",BARBIEN
End DoDot:4
QUIT
+22 SET BARBILN=$$VAL^XBDIQ1(90053.05,BARDM,.01)
+23 SET BARDAC=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,3)
SET BARDBDT=$PIECE(^(0),U,7)
SET BARD3P=$PIECE(^(0),U,17)
+24 SET BARD3PD=$PIECE($GET(^BARBL(DUZ(2),BARBIEN,0)),U,22)
+25 ;DUPLICATE BILL / NONEX CLAIM #
IF '$DATA(^ABMDBILL(BARD3PD,BARD3P))
QUIT
+26 SET BARDMINS=$PIECE($GET(^ABMDBILL(BARD3PD,BARD3P,0)),U,8)
+27 SET BARDM("DOS")=$$VAL^XBDIQ1(90050.01,BARBIEN,102)
+28 SET BARNPIF=$PIECE($$NPI^XUSNPI("Organization_ID",DUZ(2)),U)
+29 SET BARNPIP=$SELECT(+$$GET1^DIQ(90050.01,BARBIEN,113,"I")'=0:$PIECE($$NPI^XUSNPI("Individual_ID",$$GET1^DIQ(90050.01,BARBIEN,113,"I")),U),1:"")
+30 ;P.OTT
IF $PIECE(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0
Begin DoDot:4
+31 WRITE !,"Bill status of ",$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,1)," changed. Flagging DL as PAID."
+32 DO PAID(BARDM,BARDMC)
QUIT
End DoDot:4
QUIT
+33 DO INSTYP^BARDMU
+34 SET BARDI=$$VAL^XBDIQ1(90050.02,BARDAC,.01)
+35 ;not insurer type or insurer we are looking for
IF '$DATA(BARDINS(BARDI))&'$DATA(BARDINS(BARDITY))
Begin DoDot:4
End DoDot:4
QUIT
+36 DO POLCHK
+37 SET BARTOT=BARTOT+1
+38 IF $DATA(^TMP("BARDME",$JOB,BARDM))
SET BARNOK1=BARNOK1+1
+39 IF '$DATA(^TMP("BARDME",$JOB,BARDM))
SET BAROK1=BAROK1+1
+40 ;?????DO WE NEED THIS??
IF BARCT<BARPMX
Begin DoDot:4
+41 IF $DATA(^TMP("BARDME",$JOB,BARDM))
SET BARNOK2=BARNOK2+1
+42 IF '$DATA(^TMP("BARDME",$JOB,BARDM))
SET BAROK2=BAROK2+1
+43 SET BARCT=BARCT+1
+44 IF BARPSRT=""
SET ^TMP("BARDM",$JOB,"PRT",BARCYCLE,BARDMINS,BARDM,BARDMC)=""
+45 ;POLICYHOLDER,CYCLE,INS
IF $EXTRACT(BARPSRT)="P"
Begin DoDot:5
+46 SET BARSORT=BARDM("POL_HOLDER")
IF BARSORT=""
SET BARSORT=" "
+47 SET ^TMP("BARDM",$JOB,"POLHNAME",BARSORT,BARCYCLE,BARDMINS,BARDM,BARDMC)=""
End DoDot:5
+48 ;INSNAME,CYCLE
IF $EXTRACT(BARPSRT)="I"
Begin DoDot:5
+49 SET BARSORT=BARDM("INS_NM")
IF BARSORT=""
SET BARSORT=" "
+50 SET ^TMP("BARDM",$JOB,"INSNAME",BARSORT,BARCYCLE,BARDMINS,BARDM,BARDMC)=""
End DoDot:5
+51 ;CYCLE;INS,POLICYHOLDER
IF $EXTRACT(BARPSRT)="C"
Begin DoDot:5
+52 SET BARSORT1=BARDM("INS_NM")
IF BARSORT1=""
SET BARSORT1=" "
+53 SET BARSORT2=BARDM("POL_HOLDER")
IF BARSORT2=""
SET BARSORT2=" "
+54 SET ^TMP("BARDM",$JOB,"CYCLE",BARCYCLE,BARSORT1,BARDMINS,BARSORT2,BARDM,BARDMC)=""
End DoDot:5
+55 ;for BARDMRQN report (after printing) ;
SET ^TMP("BARDMQN",$JOB,BARCYCLE,BARDM,BARDMC)=BARDMINS
End DoDot:4
End DoDot:3
IF BARQ
QUIT
End DoDot:2
IF BARQ
QUIT
End DoDot:1
IF BARQ
QUIT
+56 DO SUMMARY
+57 ;DISPLAY SUMMARY OF LETTERS TO BE PRINTED ;
IF BARQ
QUIT
+58 ;--->SELECT PRINTER
DO ^%ZIS
+59 IF POP
QUIT
+60 USE IO
+61 ;SORT BY: <NIL> P(OLICY HOLDER) I(INSURANCE NAME)
+62 IF BARPSRT=""
DO SORT0
+63 IF $EXTRACT(BARPSRT)="P"
DO SORT1
+64 IF $EXTRACT(BARPSRT)="I"
DO SORT2
+65 IF $EXTRACT(BARPSRT)="C"
DO SORT3
+66 ;CLOSE PRINTER
DO ^%ZISC
+67 ;--------TERMINAL IO ----------------------
+68 Begin DoDot:1
+69 SET Y=$$DIR^XBDIR("Y","Do you wish to display the print report","Y")
+70 IF +Y<1
QUIT
+71 ;DISPLAY PRINT REPORT
DO ^BARDMRQN
+72 KILL DIR
SET (X,Y)=""
+73 SET DIR(0)="E"
+74 SET DIR("A")="Hit ENTER to continue"
+75 DO ^DIR
+76 KILL DIR
End DoDot:1
IF Y<1
QUIT
+77 QUIT
SORT0 SET CY=0
+1 FOR BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4"
Begin DoDot:1
+2 SET CY=CY+1
SET BARDMINS=""
FOR
SET BARDMINS=$ORDER(^TMP("BARDM",$JOB,"PRT",BARCYCLE,BARDMINS))
IF 'BARDMINS
QUIT
Begin DoDot:2
+3 SET BARDM=0
FOR
SET BARDM=$ORDER(^TMP("BARDM",$JOB,"PRT",BARCYCLE,BARDMINS,BARDM))
IF 'BARDM
QUIT
Begin DoDot:3
+4 SET BARDMC=0
FOR
SET BARDMC=$ORDER(^TMP("BARDM",$JOB,"PRT",BARCYCLE,BARDMINS,BARDM,BARDMC))
IF 'BARDMC
QUIT
DO ONEDM
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT
SORT1 ;
+1 SET BARSORT=""
FOR
SET BARSORT=$ORDER(^TMP("BARDM",$JOB,"POLHNAME",BARSORT))
IF BARSORT=""
QUIT
Begin DoDot:1
+2 SET CY=0
FOR BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4"
Begin DoDot:2
+3 SET CY=CY+1
SET BARDMINS=""
FOR
SET BARDMINS=$ORDER(^TMP("BARDM",$JOB,"POLHNAME",BARSORT,BARCYCLE,BARDMINS))
IF 'BARDMINS
QUIT
Begin DoDot:3
+4 SET BARDM=0
FOR
SET BARDM=$ORDER(^TMP("BARDM",$JOB,"POLHNAME",BARSORT,BARCYCLE,BARDMINS,BARDM))
IF 'BARDM
QUIT
Begin DoDot:4
+5 SET BARDMC=0
FOR
SET BARDMC=$ORDER(^TMP("BARDM",$JOB,"POLHNAME",BARSORT,BARCYCLE,BARDMINS,BARDM,BARDMC))
IF 'BARDMC
QUIT
DO ONEDM
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
SORT2 ;
+1 SET BARSORT=""
FOR
SET BARSORT=$ORDER(^TMP("BARDM",$JOB,"INSNAME",BARSORT))
IF BARSORT=""
QUIT
Begin DoDot:1
+2 SET CY=0
FOR BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4"
Begin DoDot:2
+3 SET CY=CY+1
SET BARDMINS=""
FOR
SET BARDMINS=$ORDER(^TMP("BARDM",$JOB,"INSNAME",BARSORT,BARCYCLE,BARDMINS))
IF 'BARDMINS
QUIT
Begin DoDot:3
+4 SET BARDM=0
FOR
SET BARDM=$ORDER(^TMP("BARDM",$JOB,"INSNAME",BARSORT,BARCYCLE,BARDMINS,BARDM))
IF 'BARDM
QUIT
Begin DoDot:4
+5 SET BARDMC=0
FOR
SET BARDMC=$ORDER(^TMP("BARDM",$JOB,"INSNAME",BARSORT,BARCYCLE,BARDMINS,BARDM,BARDMC))
IF 'BARDMC
QUIT
DO ONEDM
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
SORT3 SET CY=0
+1 FOR BARCYCLE="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4"
Begin DoDot:1
+2 SET CY=CY+1
SET BARSORT1=""
FOR
SET BARSORT1=$ORDER(^TMP("BARDM",$JOB,"CYCLE",BARCYCLE,BARSORT1))
IF BARSORT1=""
QUIT
Begin DoDot:2
+3 SET BARDMINS=""
FOR
SET BARDMINS=$ORDER(^TMP("BARDM",$JOB,"CYCLE",BARCYCLE,BARSORT1,BARDMINS))
IF 'BARDMINS
QUIT
Begin DoDot:3
+4 SET BARSORT2=""
FOR
SET BARSORT2=$ORDER(^TMP("BARDM",$JOB,"CYCLE",BARCYCLE,BARSORT1,BARDMINS,BARSORT2))
IF BARSORT2=""
QUIT
Begin DoDot:4
+5 SET BARDM=0
FOR
SET BARDM=$ORDER(^TMP("BARDM",$JOB,"CYCLE",BARCYCLE,BARSORT1,BARDMINS,BARSORT2,BARDM))
IF 'BARDM
QUIT
Begin DoDot:5
+6 SET BARDMC=0
FOR
SET BARDMC=$ORDER(^TMP("BARDM",$JOB,"CYCLE",BARCYCLE,BARSORT1,BARDMINS,BARSORT2,BARDM,BARDMC))
IF 'BARDMC
QUIT
DO ONEDM
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
ONEDM ;
+1 SET BARDM("DOS")=""
+2 SET X=$PIECE(^BARDM(DUZ(2),BARDM,100,BARDMC,0),U,6)
SET X2="2$"
DO COMMA^%DTC
SET BARAMTO="$"_$PIECE(X,"$",2)
+3 SET BARBIEN=$PIECE(^BARDM(DUZ(2),BARDM,0),U)
+4 SET BARBILN=$$VAL^XBDIQ1(90053.05,BARDM,.01)
+5 SET BARDAC=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,3)
SET BARDBDT=$PIECE(^(0),U,7)
SET BARD3P=$PIECE(^(0),U,17)
+6 SET BARD3PD=$PIECE($GET(^BARBL(DUZ(2),BARBIEN,0)),U,22)
+7 SET BARDM("DOS")=$$VAL^XBDIQ1(90050.01,BARBIEN,102)
+8 ;P.OTT
SET BARDOB=$$GET1^DIQ(2,BARDM("PAT_IEN"),".03","E")
+9 SET BARNPIF=$PIECE($$NPI^XUSNPI("Organization_ID",DUZ(2)),U)
+10 SET BARNPIP=$SELECT(+$$GET1^DIQ(90050.01,BARBIEN,113,"I")'=0:$PIECE($$NPI^XUSNPI("Individual_ID",$$GET1^DIQ(90050.01,BARBIEN,113,"I")),U),1:"")
+11 DO INSTYP^BARDMU
+12 SET BARDI=$$VAL^XBDIQ1(90050.02,BARDAC,.01)
+13 IF $PIECE(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0
QUIT
+14 DO POLCHK
+15 DO PRINT^BARDMLP1
+16 DO CYUP
+17 DO LGUP
+18 QUIT
POLCHK ;TEST FOR POLICY NO, POLICY HOLDER AND POLICY HOLDER DOB
+1 ;BAR*1.8*24
SET BARMIN=0
+2 IF BARDACG'="VA("
Begin DoDot:1
+3 SET BARDM("PAT_IEN")=$PIECE(^BARBL(DUZ(2),BARBIEN,1),U)
+4 SET BARHRN=$PIECE($GET(^AUPNPAT(BARDM("PAT_IEN"),41,DUZ(2),0)),U,2)
+5 SET BARPAT=$PIECE(^DPT(BARDM("PAT_IEN"),0),U)
+6 SET BARDOB=$$GET1^DIQ(2,BARDM("PAT_IEN"),".03","E")
End DoDot:1
+7 DO VARSET
+8 ;I BARDACG="AUTNINS(" D INSCHK ;OLD CODE
+9 ;NOT A PAT 12/04/2013
IF BARDACG="AUTNINS("
DO INSCHK
SET BARMIN=2
+10 IF BARDACG="AUPNPAT("
DO PATCHK
+11 IF BARDACG="VA("
DO PERCHK
+12 QUIT
INSCHK ;
+1 SET BARDM("INS")=^AUTNINS(BARDACI,0)
+2 SET BARDM("INS_NM")=$PIECE(BARDM("INS"),U)
SET BARDM("INS_STR")=$PIECE(BARDM("INS"),U,2)
+3 SET BARDM("INS_CTY")=$PIECE(BARDM("INS"),U,3)
SET BARDM("INS_ST")=$PIECE(BARDM("INS"),U,4)
+4 SET BARDM("INS_ZP")=$PIECE(BARDM("INS"),U,5)
+5 SET BARDM("INS_TX")=$PIECE(BARDM("INS"),U,11)
+6 SET BARTST=0
+7 IF $DATA(^ABMDBILL(BARD3PD,BARD3P,13,"B",BARDACI))
Begin DoDot:1
+8 SET BARL=""
SET BARL=$ORDER(^ABMDBILL(BARD3PD,BARD3P,13,"B",BARDACI,BARL))
+9 DO INSCHK1
End DoDot:1
+10 IF BARTST=1
QUIT
+11 SET BARL=0
FOR
SET BARL=$ORDER(^ABMDBILL(BARD3PD,BARD3P,13,BARL))
IF BARL'?1N.N
QUIT
Begin DoDot:1
+12 IF $PIECE(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,11)=BARDACI
DO INSCHK1
End DoDot:1
IF BARTST=1
QUIT
+13 ;end new code
+14 QUIT
INSCHK1 ;
+1 ;MCR^BARDMRE UPDATED FOR NMCI P27 IHS/DIT/CPC - 20171031
IF $PIECE(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,4)'=""
DO MCR^BARDMRE
QUIT
+2 ;RR^BARDMRE UPDATED FOR NMCI P27 IHS/DIT/CPC - 20171031
IF $PIECE(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,5)'=""
DO RR^BARDMRE
QUIT
+3 IF $PIECE(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,7)'=""
DO MCD^BARDMRE
QUIT
+4 IF $PIECE(^ABMDBILL(BARD3PD,BARD3P,13,BARL,0),U,8)'=""
DO PRVT^BARDMRE
QUIT
+5 ;end new code
+6 QUIT
PATCHK ;
+1 SET BARDM("INS_NM")=$PIECE(BARPAT,",",2)_" "_$PIECE(BARPAT,",",1)_" "_$PIECE(BARPAT,",",3)
+2 SET BARDM("INS_STR")=$$VAL^XBDIQ1(2,BARDM("PAT_IEN"),.111)
+3 SET BARDM("INS_CTY")=$$VAL^XBDIQ1(2,BARDM("PAT_IEN"),.114)
+4 ;S BARDM("INS_ST")=$P(^DPT(BARDM("PAT_IEN"),.11),U,5)
+5 SET BARDM("INS_ST")=$PIECE($GET(^DPT(BARDM("PAT_IEN"),.11)),U,5)
+6 SET BARDM("INS_ZP")=$$VAL^XBDIQ1(2,BARDM("PAT_IEN"),.116)
+7 ;**CHECK AND SET BARMIN FOR MINOR OR NOT
+8 SET X1=$$VALI^XBDIQ1(90050.01,BARBIEN,102)
+9 SET X2=$$VALI^XBDIQ1(2,BARDM("PAT_IEN"),.03)
+10 DO ^%DTC
SET AGE=X\365.25
IF AGE>17
SET BARMIN=1
+11 QUIT
PERCHK ;
+1 SET BARPAT=$$VAL^XBDIQ1(200,BARDACI,.01)
+2 SET BARDM("INS_NM")=$PIECE(BARPAT,",",2)_" "_$PIECE(BARPAT,",",1)_" "_$PIECE(BARPAT,",",3)
+3 SET BARDM("INS_STR")=$$VAL^XBDIQ1(200,BARDACI,.111)
+4 SET BARDM("INS_CTY")=$$VAL^XBDIQ1(200,BARDACI,.114)
+5 SET BARDM("INS_ST")=$$VAL^XBDIQ1(200,BARDACI,.115)
+6 SET BARDM("INS_ZP")=$$VAL^XBDIQ1(200,BARDACI,.116)
+7 QUIT
CYUP ;CYCLE UPDATE - SET LETTER STATUS AND QUE
+1 SET (DIC,DIE)="^BARDM(DUZ(2),"_BARDM_",100,"
SET DA(1)=BARDM
SET DA=BARDMC
+2 ;S DR=".03///P;.04///"_DUZ_";.05///"_DT ;OLD CODE
+3 ;P.OTT FIX FOR YAKAMA '??'
SET DR=".03////P;.04////"_DUZ_";.05////"_DT
+4 DO ^DIE
+5 IF CY=4
KILL DIE,DIC,DA,DR
QUIT
+6 ;SET NEW LETTER STATUS AND QUE
+7 SET DIC(0)="L"
SET X="CYCLE "_(CY+1)
+8 DO ^DIC
+9 IF +Y<0
QUIT
+10 SET DA=+Y
+11 SET DR=".02///"_BARPCP(CY+1)_";.03///Q"_";.06///"_$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,15)
+12 DO ^DIE
+13 KILL DIE,DIC,DA,DR
+14 QUIT
LGADD ;ENTRY TO LOG FILE
+1 DO NOW^%DTC
+2 SET DIC(0)="L"
SET DIC="^BARDMLG("_DUZ(2)_","
+3 SET X=%
+4 DO ^DIC
+5 SET BARLG=+Y
+6 KILL DA
+7 QUIT
LGCYL ;ADD CYCLE TO LOG FILE
+1 SET DA(1)=BARLG
+2 SET DIC(0)="L"
SET DIC="^BARDMLG("_DUZ(2)_","_BARLG_",100,"
+3 SET DIC("P")=$PIECE(^DD(90053.08,100,0),U,2)
+4 SET X=BARCYCLE
+5 DO ^DIC
+6 SET BARLGC=+Y
+7 KILL DA
+8 QUIT
LGUP ;ADD BILL TO LOG FILE
+1 ;GET NEW BATCH IEN
IF '$DATA(BARLG)
DO LGADD
+2 ;P.OTT 9/18/2013
IF $DATA(^BARDMLG(DUZ(2),BARLG,100,"B",BARCYCLE))
SET BARLGC=$ORDER(^BARDMLG(DUZ(2),BARLG,100,"B",BARCYCLE,""))
+3 ;;GET NEW SUBFILE IEN
IF '$DATA(^BARDMLG(DUZ(2),BARLG,100,"B",BARCYCLE))
DO LGCYL
+4 KILL DIC,DIE,DIR,X,Y,DA,DR
+5 SET DA(2)=BARLG
+6 SET DA(1)=BARLGC
+7 SET DIC(0)="L"
+8 SET DIC="^BARDMLG("_DUZ(2)_","_BARLG_",100,"_BARLGC_",10,"
+9 SET DIC("P")=$PIECE(^DD(90053.09,10,0),U,2)
+10 SET X=BARBILN
+11 DO ^DIC
+12 SET $PIECE(^BARDMLG(DUZ(2),BARLG,100,BARLGC,0),U,2)=$PIECE(^BARDMLG(DUZ(2),BARLG,100,BARLGC,0),U,2)+1
+13 QUIT
SUMMARY ;
+1 SET BARQ=0
+2 DO UNDL
+3 WRITE !," # of letters in queue : ",$JUSTIFY(BARTOT,6)
+4 IF BAR2PRT=2
WRITE " with errors."
+5 IF BAR2PRT>2
WRITE " incl. ",BARNOK1," letter(s) with errors."
+6 IF BARTOT
WRITE !,"# of letters that will be printed : ",$JUSTIFY(BAROK2+BARNOK2,6)
+7 IF BARTOT>BARPMX
WRITE !,"NOTE: According to the parameter setup only ",BARPMX," letters will be printed."
+8 DO UNDL
+9 ;
+10 KILL DIR
SET (X,Y)=""
+11 SET DIR(0)="E"
+12 IF 'BARTOT
SET DIR("A")="There is nothing to print. Hit ENTER to quit"
+13 IF BARTOT
SET DIR("A")="Hit ENTER to continue printing, or ^ to quit (no printing)"
+14 DO ^DIR
+15 KILL DIR
+16 IF X="^"
SET BARQ=1
+17 IF 'BARTOT
SET BARQ=1
+18 QUIT
UNDL ;
+1 NEW BARTMP
+2 WRITE !
FOR BARTMP=1:1:78
WRITE "-"
+3 QUIT
PAID(BARDM,BARDMC) ;SET THE PRINT QUEUED STATUS TO NOT QUEUED AND BILL STATUS TO PAID ;P.OTT
+1 SET DIE="^BARDM("_DUZ(2)_","_BARDM_",100,"
SET DA(1)=BARDM
SET DA=BARDMC
+2 SET DR=".03///N"
+3 DO ^DIE
+4 KILL DIE,DA,DR
+5 SET DIE="^BARDM("_DUZ(2)_","
SET DA=BARDM
SET DR=".02///P"
+6 DO ^DIE
+7 KILL DIE,DA,DR
+8 ;EOR--
QUIT
