- BARPUC2 ; IHS/SD/LSL - UNALLOCATED PATIENT LOOKUP ; 01/26/2009
- ;;1.8;IHS ACCOUNTS RECEIVABLE;**17,23**;OCT 26, 2005
- ;
- ;** patient a/r lookup based on from/thru dos
- ;** called from ^BARPST
- ;** BARPASS = PATDFN^BEGDOS^ENDDOS
- ;** builds an array that includes all entries from a/r that meet the
- ; criteria.
- ;HEAT93190 DEC 2012 P.OTTIS NOHEAT MARK DUPLICATE BILLS
- ;MAR 2013 P.OTTIS ADDED NEW VA billing
- ; *********************************************************************
- ;
- EN(BARPASS) ;EP
- N DIC,DIQ,DR,BARBLV,BARDT,BARPAT,BARBEG,BAREND,BARHIT,BARCNT
- K ^BARTMP($J)
- Q:+BARPASS=0
- S BARPAT=+BARPASS
- S BARBEG=$P(BARPASS,U,2)
- S BAREND=$P(BARPASS,U,3)
- S X1=BARBEG
- S X2=-1
- D C^%DTC
- S BARDT=X
- S DIC="^BARBL(DUZ(2),"
- S DR=".01;3;13;15"
- S DIQ="BARBLV("
- S BARCNT=0
- F S BARDT=$O(^BARBL(DUZ(2),"ABC",BARPAT,BARDT)) Q:'BARDT!(BARDT>BAREND) D
- . S BARBDA=0
- . F S BARBDA=$O(^BARBL(DUZ(2),"ABC",BARPAT,BARDT,BARBDA)) Q:'BARBDA D
- .. S DA=BARBDA
- .. D EN^XBDIQ1
- .. S BARCNT=BARCNT+1
- .. S ^BARTMP($J,BARBDA,BARCNT)=BARDT_U_BARBLV(.01)_U_BARBLV(13)_U_BARBLV(3)_U_BARBLV(15)
- .. S ^BARTMP($J,"B",BARCNT,BARBDA)=""
- .. K BARBLV
- Q BARCNT
- ; *********************************************************************
- ;
- HIT(BARPASS) ;
- ; ** display a/r bills found
- N BARBDA,BARLIN,BARREC,BARBLO,BAREIN1,BAREIN2,BARDPTR
- S (BARBDA,BARPG,BARSTOP)=0
- D HEAD
- F S BARBDA=$O(^BARTMP($J,BARBDA)) Q:'BARBDA D Q:BARSTOP
- . S BARLIN=$O(^BARTMP($J,BARBDA,""))
- . S BARREC=^BARTMP($J,BARBDA,BARLIN)
- . S BARBLO=$P(BARREC,U,2)
- . I $D(^BARTR(DUZ(2),"AM4",+BARBLO)) S BARBLO="m"_BARBLO
- . S BARSTOP=$$CHKLINE(0) Q:BARSTOP
- . S BARTMP=$$DUPLBILL^BARPNP2($P(BARREC,U,2)) I BARTMP>0 D ;-------->P.OTT MARK DUPLICATE BILLS
- . . S BAREIN1=$P(BARTMP,"^",2)
- . . S BAREIN2=$P(BARTMP,"^",3)
- . . S BARDPTR=$P(BARTMP,"^",4)
- . . I BARDPTR=3 S BARBLO="?"_BARBLO Q
- . . I BARBDA=BAREIN1,BARDPTR=1 S BARBLO="!"_BARBLO Q ;! = ORPHANT (NO DATA IN 3PB)
- . . I BARBDA=BAREIN2,BARDPTR=2 S BARBLO="!"_BARBLO Q ;d = DUPLICATE (CORRECT ONE)
- . . I BARBDA=BAREIN1 S BARBLO="d"_BARBLO Q
- . . I BARBDA=BAREIN2 S BARBLO="d"_BARBLO Q
- . ;---------------------------------------------------------< P.OTT
- . W !,BARLIN
- . W ?6,$$SDT^BARDUTL($P(BARREC,U,1))
- . W ?18,BARBLO
- . W ?32,$J($P(BARREC,U,3),8,2)
- . W ?44,$E($P(BARREC,U,4),1,23)
- . W ?70,$J($P(BARREC,U,5),8,2)
- Q
- ; *********************************************************************
- ;
- HEAD ;
- W $$EN^BARVDF("IOF"),!
- N BARPTNAM
- S BARPG=BARPG+1
- S BARPTNAM=$P(^DPT(+BARPASS,0),U,1)
- I $D(^BARTR(DUZ(2),"AM5",+BARPASS)) S BARPTNAM="(msg) "_BARPTNAM
- W "Claims for "_BARPTNAM_" from "_$$SDT^BARDUTL($P(BARPASS,U,2))_" to "_$$SDT^BARDUTL($P(BARPASS,U,3))
- W ?(IOM-15),"Page: "_BARPG
- W !!?32,"Billed",?70,"Current"
- W !,"Line #",?8,"DOS",?18,"Claim #",?32,"Amount",?44,"Billed To",?70,"Balance"
- S BARDSH=""
- S $P(BARDSH,"-",IOM)=""
- W !,BARDSH
- Q
- ; *********************************************************************
- ;
- HIT1(BARPASS) ; EP
- ; ** display a/r bills found
- N BARHIT,BARLIN,BARREC,BARBLO,BAREIN1,BAREIN2,BARDPTR
- S (BARTPAY,BARTADJ,BARHIT,BARPG,BARSTOP)=0
- D HEAD1
- F S BARHIT=$O(^BARTMP($J,BARHIT)) Q:'BARHIT D Q:BARSTOP
- . S BARLIN=$O(^BARTMP($J,BARHIT,""))
- . S BARREC=^BARTMP($J,BARHIT,BARLIN)
- . S BARBLO=$P(BARREC,U,2)
- . I $D(^BARTR(DUZ(2),"AM4",+BARBLO)) S BARBLO="m"_BARBLO
- . S BARTMP=$$DUPLBILL^BARPNP2($P(BARREC,U,2)) I BARTMP>0 D ;-------->P.OTT MARK DUPLICATE BILLS
- . . S BAREIN1=$P(BARTMP,"^",2)
- . . S BAREIN2=$P(BARTMP,"^",3)
- . . S BARDPTR=$P(BARTMP,"^",4)
- . . I BARDPTR=3 S BARBLO="?"_BARBLO Q
- . . I BARHIT=BAREIN1,BARDPTR=1 S BARBLO="!"_BARBLO Q ;! = ORPHANT (NO DATA IN 3PB)
- . . I BARHIT=BAREIN2,BARDPTR=2 S BARBLO="!"_BARBLO Q ;d = DUPLICATE (CORRECT ONE)
- . . I BARHIT=BAREIN1 S BARBLO="d"_BARBLO Q
- . . I BARHIT=BAREIN2 S BARBLO="d"_BARBLO Q
- . ;---------------------------------------------------------< P.OTT
- . S BARTPAY=BARTPAY+$P(BARREC,U,6)
- . S BARTADJ=BARTADJ+$P(BARREC,U,7)
- . S BARSTOP=$$CHKLINE(1) Q:BARSTOP
- . W !,BARLIN
- . W ?6,$$SDT^BARDUTL($P(BARREC,U,1))
- . W ?18,BARBLO
- . W ?32,$J($P(BARREC,U,3),8,2)
- . W ?44,$J($P(BARREC,U,6),8,2)
- . W ?56,$J($P(BARREC,U,7),8,2)
- . W ?70,$J($P(BARREC,U,5),8,2)
- Q
- ; *********************************************************************
- ;
- HEAD1 ;
- W $$EN^BARVDF("IOF"),!
- N BARPTNAM
- S BARPG=BARPG+1
- S BARPTNAM=$P(^DPT(+BARPASS,0),U,1)
- I $D(^BARTR(DUZ(2),"AM5",+BARPASS)) S BARPTNAM="(msg) "_BARPTNAM
- W "Claims for "_BARPTNAM_" from "_$$SDT^BARDUTL($P(BARPASS,U,2))_" to "_$$SDT^BARDUTL($P(BARPASS,U,3))
- W ?(IOM-15),"Page: "_BARPG
- W !!?32,"Billed",?44,"Current",?56,"Current",?70,"Current"
- W !,"Line #",?8,"DOS",?18,"Claim #",?32,"Amount",?44,"Payments",?56,"Adjust.",?70,"Balance"
- S BARDSH=""
- S $P(BARDSH,"-",IOM)=""
- W !,BARDSH
- Q
- ; *********************************************************************
- ;
- CHKLINE(BARHD) ;
- ; Q 0 = CONTINUE
- ; Q 1 = STOP
- N X
- I ($Y+5)<IOSL Q 0
- W !?(IOM-15),"continued==>"
- D EOP^BARUTL(0)
- I 'Y Q 1
- I BARHD=0 D HEAD
- I BARHD=1 D HEAD1
- Q 0
- ; Begin new code BAR*1.8*17 ADD COMMENTS ENTRY TO PUC ITEMS
- ; - per Adrian 2/12/10 PKD:BAR*1.8.17 2/12/10
- ITMSG ;
- ;BAR1.8*17 PKD 2/24/2010
- W !!!,"Create a New Message for: "
- W !!,"Credit",?10,"Account",?42,"Batch",?71,"Item"
- W !?8,"TRANS DATE",?32,"ALLOW CAT",?46,"TDN",?68,"STATUS"
- W !
- S BARDSH=""
- S $P(BARDSH,"-",80)="" W BARDSH
- ;
- W $J(BARTX(2),8,2)
- W ?10,$E(BARTX(6),1,30),?42,BARTX(14)
- W ?71,BARTX(15) ;coll. item
- S D0=BARTX(6,"I")
- I D0']"" D Q ;MRS:BAR*1.8*7 IM30586
- . W !,"** ERROR--MISSING ALLOCATION INFO "
- . D EOP^BARUTL(1)
- S BARALLC=$$VALI^BARVPM(8) ;CODE
- I BARALLC="" D Q ;MRS:BAR*1.8*7 IM30586
- . W !,"** ERROR--MISSING ALLOCATION INFO "
- . D EOP^BARUTL(1)
- S Y=$P(BARTX("ID"),":") D DD^%DT
- W !?8,Y,?32,$E($TR($P($T(@BARALLC),";;",3)," ",""),1,12) ;P.OTT SHOW BOTH FIELDS
- W ?46
- W $S($G(BARTX(17))'="":BARTX(17),$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E")'="":$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E"),1:"<NO TDN>")
- W ?68,$S($O(^BAR(90052,"D",BARTX(14),0))'="":"LETTER",1:"")
- ;
- K DIE,DIC,DA,DIR
- S DA(1)=BARTX(14,"I"),DA=BARTX(15,"I")
- S DR=107 ; SubFile ITEMS in A/R Collect Batch - Question #107: PUC comments
- S DIE="^BARCOL("_DUZ(2)_","_DA(1)_",1,"
- D ^DIE
- Q
- ;
- PRTQ ; Ask whether to print comments on Letters to Finance 1.8.17 2/25/10 PKD
- Q:$G(^BARCOL(DUZ(2),BARTX(14,"I"),1,BARTX(15,"I"),7,0))=""
- K DIR
- W !!,?31,"**Messages Exist**",!
- S DIR("A")="Do you want them to print on the letter? ",DIR("B")="YES",DIR(0)="YOA"
- D ^DIR
- I Y=1 S BARPRTQ=1
- Q
- ; ********************************************************************
- ;THIS TABLE REPLICATES ^AUTTINTY INSURER TYPE (21 ENTRIES) P.OTT 4/12/2013
- ;AND MAPS INSURER TYPE CODE TO CATEGORY (IE: W --> OTHER)
- H ;;PRIVATE INSURANCE;;HMO
- M ;;PRIVATE INSURANCE;;MEDICARE SUPPL.
- D ;;MEDICAID;;MEDICAID FI
- R ;;MEDICARE;;MEDICARE FI
- P ;;PRIVATE INSURANCE;;PRIVATE INSURANCE
- W ;;OTHER;;WORKMEN'S COMP
- C ;;OTHER;;CHAMPUS
- N ;;OTHER;;NON-BENEFICIARY (NON-INDIAN)
- I ;;OTHER;;INDIAN PATIENT
- K ;;MEDICAID;;CHIP (KIDSCARE)
- T ;;OTHER;;THIRD PARTY LIABILITY
- G ;;OTHER;;GUARANTOR
- MD ;;MEDICARE;;MCR PART D
- MH ;;MEDICARE;;MEDICARE HMO
- MMC ;;MEDICARE;;MCR MANAGED CARE
- TSI ;;OTHER;;TRIBAL SELF INSURED
- SEP ;;OTHER;;STATE EXCHANGE PLAN
- FPL ;;MEDICAID;;FPL 133 PERCENT
- MC ;;MEDICARE;;MCR PART C
- F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
- V ;;VETERAN;;VETERANS MEDICAL BENEFITS
- ;;***END OF TABLE**
- BARPUC2 ; IHS/SD/LSL - UNALLOCATED PATIENT LOOKUP ; 01/26/2009
- +1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**17,23**;OCT 26, 2005
- +2 ;
- +3 ;** patient a/r lookup based on from/thru dos
- +4 ;** called from ^BARPST
- +5 ;** BARPASS = PATDFN^BEGDOS^ENDDOS
- +6 ;** builds an array that includes all entries from a/r that meet the
- +7 ; criteria.
- +8 ;HEAT93190 DEC 2012 P.OTTIS NOHEAT MARK DUPLICATE BILLS
- +9 ;MAR 2013 P.OTTIS ADDED NEW VA billing
- +10 ; *********************************************************************
- +11 ;
- EN(BARPASS) ;EP
- +1 NEW DIC,DIQ,DR,BARBLV,BARDT,BARPAT,BARBEG,BAREND,BARHIT,BARCNT
- +2 KILL ^BARTMP($JOB)
- +3 IF +BARPASS=0
- QUIT
- +4 SET BARPAT=+BARPASS
- +5 SET BARBEG=$PIECE(BARPASS,U,2)
- +6 SET BAREND=$PIECE(BARPASS,U,3)
- +7 SET X1=BARBEG
- +8 SET X2=-1
- +9 DO C^%DTC
- +10 SET BARDT=X
- +11 SET DIC="^BARBL(DUZ(2),"
- +12 SET DR=".01;3;13;15"
- +13 SET DIQ="BARBLV("
- +14 SET BARCNT=0
- +15 FOR
- SET BARDT=$ORDER(^BARBL(DUZ(2),"ABC",BARPAT,BARDT))
- IF 'BARDT!(BARDT>BAREND)
- QUIT
- Begin DoDot:1
- +16 SET BARBDA=0
- +17 FOR
- SET BARBDA=$ORDER(^BARBL(DUZ(2),"ABC",BARPAT,BARDT,BARBDA))
- IF 'BARBDA
- QUIT
- Begin DoDot:2
- +18 SET DA=BARBDA
- +19 DO EN^XBDIQ1
- +20 SET BARCNT=BARCNT+1
- +21 SET ^BARTMP($JOB,BARBDA,BARCNT)=BARDT_U_BARBLV(.01)_U_BARBLV(13)_U_BARBLV(3)_U_BARBLV(15)
- +22 SET ^BARTMP($JOB,"B",BARCNT,BARBDA)=""
- +23 KILL BARBLV
- End DoDot:2
- End DoDot:1
- +24 QUIT BARCNT
- +25 ; *********************************************************************
- +26 ;
- HIT(BARPASS) ;
- +1 ; ** display a/r bills found
- +2 NEW BARBDA,BARLIN,BARREC,BARBLO,BAREIN1,BAREIN2,BARDPTR
- +3 SET (BARBDA,BARPG,BARSTOP)=0
- +4 DO HEAD
- +5 FOR
- SET BARBDA=$ORDER(^BARTMP($JOB,BARBDA))
- IF 'BARBDA
- QUIT
- Begin DoDot:1
- +6 SET BARLIN=$ORDER(^BARTMP($JOB,BARBDA,""))
- +7 SET BARREC=^BARTMP($JOB,BARBDA,BARLIN)
- +8 SET BARBLO=$PIECE(BARREC,U,2)
- +9 IF $DATA(^BARTR(DUZ(2),"AM4",+BARBLO))
- SET BARBLO="m"_BARBLO
- +10 SET BARSTOP=$$CHKLINE(0)
- IF BARSTOP
- QUIT
- +11 ;-------->P.OTT MARK DUPLICATE BILLS
- SET BARTMP=$$DUPLBILL^BARPNP2($PIECE(BARREC,U,2))
- IF BARTMP>0
- Begin DoDot:2
- +12 SET BAREIN1=$PIECE(BARTMP,"^",2)
- +13 SET BAREIN2=$PIECE(BARTMP,"^",3)
- +14 SET BARDPTR=$PIECE(BARTMP,"^",4)
- +15 IF BARDPTR=3
- SET BARBLO="?"_BARBLO
- QUIT
- +16 ;! = ORPHANT (NO DATA IN 3PB)
- IF BARBDA=BAREIN1
- IF BARDPTR=1
- SET BARBLO="!"_BARBLO
- QUIT
- +17 ;d = DUPLICATE (CORRECT ONE)
- IF BARBDA=BAREIN2
- IF BARDPTR=2
- SET BARBLO="!"_BARBLO
- QUIT
- +18 IF BARBDA=BAREIN1
- SET BARBLO="d"_BARBLO
- QUIT
- +19 IF BARBDA=BAREIN2
- SET BARBLO="d"_BARBLO
- QUIT
- End DoDot:2
- +20 ;---------------------------------------------------------< P.OTT
- +21 WRITE !,BARLIN
- +22 WRITE ?6,$$SDT^BARDUTL($PIECE(BARREC,U,1))
- +23 WRITE ?18,BARBLO
- +24 WRITE ?32,$JUSTIFY($PIECE(BARREC,U,3),8,2)
- +25 WRITE ?44,$EXTRACT($PIECE(BARREC,U,4),1,23)
- +26 WRITE ?70,$JUSTIFY($PIECE(BARREC,U,5),8,2)
- End DoDot:1
- IF BARSTOP
- QUIT
- +27 QUIT
- +28 ; *********************************************************************
- +29 ;
- HEAD ;
- +1 WRITE $$EN^BARVDF("IOF"),!
- +2 NEW BARPTNAM
- +3 SET BARPG=BARPG+1
- +4 SET BARPTNAM=$PIECE(^DPT(+BARPASS,0),U,1)
- +5 IF $DATA(^BARTR(DUZ(2),"AM5",+BARPASS))
- SET BARPTNAM="(msg) "_BARPTNAM
- +6 WRITE "Claims for "_BARPTNAM_" from "_$$SDT^BARDUTL($PIECE(BARPASS,U,2))_" to "_$$SDT^BARDUTL($PIECE(BARPASS,U,3))
- +7 WRITE ?(IOM-15),"Page: "_BARPG
- +8 WRITE !!?32,"Billed",?70,"Current"
- +9 WRITE !,"Line #",?8,"DOS",?18,"Claim #",?32,"Amount",?44,"Billed To",?70,"Balance"
- +10 SET BARDSH=""
- +11 SET $PIECE(BARDSH,"-",IOM)=""
- +12 WRITE !,BARDSH
- +13 QUIT
- +14 ; *********************************************************************
- +15 ;
- HIT1(BARPASS) ; EP
- +1 ; ** display a/r bills found
- +2 NEW BARHIT,BARLIN,BARREC,BARBLO,BAREIN1,BAREIN2,BARDPTR
- +3 SET (BARTPAY,BARTADJ,BARHIT,BARPG,BARSTOP)=0
- +4 DO HEAD1
- +5 FOR
- SET BARHIT=$ORDER(^BARTMP($JOB,BARHIT))
- IF 'BARHIT
- QUIT
- Begin DoDot:1
- +6 SET BARLIN=$ORDER(^BARTMP($JOB,BARHIT,""))
- +7 SET BARREC=^BARTMP($JOB,BARHIT,BARLIN)
- +8 SET BARBLO=$PIECE(BARREC,U,2)
- +9 IF $DATA(^BARTR(DUZ(2),"AM4",+BARBLO))
- SET BARBLO="m"_BARBLO
- +10 ;-------->P.OTT MARK DUPLICATE BILLS
- SET BARTMP=$$DUPLBILL^BARPNP2($PIECE(BARREC,U,2))
- IF BARTMP>0
- Begin DoDot:2
- +11 SET BAREIN1=$PIECE(BARTMP,"^",2)
- +12 SET BAREIN2=$PIECE(BARTMP,"^",3)
- +13 SET BARDPTR=$PIECE(BARTMP,"^",4)
- +14 IF BARDPTR=3
- SET BARBLO="?"_BARBLO
- QUIT
- +15 ;! = ORPHANT (NO DATA IN 3PB)
- IF BARHIT=BAREIN1
- IF BARDPTR=1
- SET BARBLO="!"_BARBLO
- QUIT
- +16 ;d = DUPLICATE (CORRECT ONE)
- IF BARHIT=BAREIN2
- IF BARDPTR=2
- SET BARBLO="!"_BARBLO
- QUIT
- +17 IF BARHIT=BAREIN1
- SET BARBLO="d"_BARBLO
- QUIT
- +18 IF BARHIT=BAREIN2
- SET BARBLO="d"_BARBLO
- QUIT
- End DoDot:2
- +19 ;---------------------------------------------------------< P.OTT
- +20 SET BARTPAY=BARTPAY+$PIECE(BARREC,U,6)
- +21 SET BARTADJ=BARTADJ+$PIECE(BARREC,U,7)
- +22 SET BARSTOP=$$CHKLINE(1)
- IF BARSTOP
- QUIT
- +23 WRITE !,BARLIN
- +24 WRITE ?6,$$SDT^BARDUTL($PIECE(BARREC,U,1))
- +25 WRITE ?18,BARBLO
- +26 WRITE ?32,$JUSTIFY($PIECE(BARREC,U,3),8,2)
- +27 WRITE ?44,$JUSTIFY($PIECE(BARREC,U,6),8,2)
- +28 WRITE ?56,$JUSTIFY($PIECE(BARREC,U,7),8,2)
- +29 WRITE ?70,$JUSTIFY($PIECE(BARREC,U,5),8,2)
- End DoDot:1
- IF BARSTOP
- QUIT
- +30 QUIT
- +31 ; *********************************************************************
- +32 ;
- HEAD1 ;
- +1 WRITE $$EN^BARVDF("IOF"),!
- +2 NEW BARPTNAM
- +3 SET BARPG=BARPG+1
- +4 SET BARPTNAM=$PIECE(^DPT(+BARPASS,0),U,1)
- +5 IF $DATA(^BARTR(DUZ(2),"AM5",+BARPASS))
- SET BARPTNAM="(msg) "_BARPTNAM
- +6 WRITE "Claims for "_BARPTNAM_" from "_$$SDT^BARDUTL($PIECE(BARPASS,U,2))_" to "_$$SDT^BARDUTL($PIECE(BARPASS,U,3))
- +7 WRITE ?(IOM-15),"Page: "_BARPG
- +8 WRITE !!?32,"Billed",?44,"Current",?56,"Current",?70,"Current"
- +9 WRITE !,"Line #",?8,"DOS",?18,"Claim #",?32,"Amount",?44,"Payments",?56,"Adjust.",?70,"Balance"
- +10 SET BARDSH=""
- +11 SET $PIECE(BARDSH,"-",IOM)=""
- +12 WRITE !,BARDSH
- +13 QUIT
- +14 ; *********************************************************************
- +15 ;
- CHKLINE(BARHD) ;
- +1 ; Q 0 = CONTINUE
- +2 ; Q 1 = STOP
- +3 NEW X
- +4 IF ($Y+5)<IOSL
- QUIT 0
- +5 WRITE !?(IOM-15),"continued==>"
- +6 DO EOP^BARUTL(0)
- +7 IF 'Y
- QUIT 1
- +8 IF BARHD=0
- DO HEAD
- +9 IF BARHD=1
- DO HEAD1
- +10 QUIT 0
- +11 ; Begin new code BAR*1.8*17 ADD COMMENTS ENTRY TO PUC ITEMS
- +12 ; - per Adrian 2/12/10 PKD:BAR*1.8.17 2/12/10
- ITMSG ;
- +1 ;BAR1.8*17 PKD 2/24/2010
- +2 WRITE !!!,"Create a New Message for: "
- +3 WRITE !!,"Credit",?10,"Account",?42,"Batch",?71,"Item"
- +4 WRITE !?8,"TRANS DATE",?32,"ALLOW CAT",?46,"TDN",?68,"STATUS"
- +5 WRITE !
- +6 SET BARDSH=""
- +7 SET $PIECE(BARDSH,"-",80)=""
- WRITE BARDSH
- +8 ;
- +9 WRITE $JUSTIFY(BARTX(2),8,2)
- +10 WRITE ?10,$EXTRACT(BARTX(6),1,30),?42,BARTX(14)
- +11 ;coll. item
- WRITE ?71,BARTX(15)
- +12 SET D0=BARTX(6,"I")
- +13 ;MRS:BAR*1.8*7 IM30586
- IF D0']""
- Begin DoDot:1
- +14 WRITE !,"** ERROR--MISSING ALLOCATION INFO "
- +15 DO EOP^BARUTL(1)
- End DoDot:1
- QUIT
- +16 ;CODE
- SET BARALLC=$$VALI^BARVPM(8)
- +17 ;MRS:BAR*1.8*7 IM30586
- IF BARALLC=""
- Begin DoDot:1
- +18 WRITE !,"** ERROR--MISSING ALLOCATION INFO "
- +19 DO EOP^BARUTL(1)
- End DoDot:1
- QUIT
- +20 SET Y=$PIECE(BARTX("ID"),":")
- DO DD^%DT
- +21 ;P.OTT SHOW BOTH FIELDS
- WRITE !?8,Y,?32,$EXTRACT($TRANSLATE($PIECE($TEXT(@BARALLC),";;",3)," ",""),1,12)
- +22 WRITE ?46
- +23 WRITE $SELECT($GET(BARTX(17))'="":BARTX(17),$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E")'="":$$GET1^DIQ(90051.1101,BARTX(15,"I")_","_BARTX(14,"I")_",",20,"E"),1:"<NO TDN>")
- +24 WRITE ?68,$SELECT($ORDER(^BAR(90052,"D",BARTX(14),0))'="":"LETTER",1:"")
- +25 ;
- +26 KILL DIE,DIC,DA,DIR
- +27 SET DA(1)=BARTX(14,"I")
- SET DA=BARTX(15,"I")
- +28 ; SubFile ITEMS in A/R Collect Batch - Question #107: PUC comments
- SET DR=107
- +29 SET DIE="^BARCOL("_DUZ(2)_","_DA(1)_",1,"
- +30 DO ^DIE
- +31 QUIT
- +32 ;
- PRTQ ; Ask whether to print comments on Letters to Finance 1.8.17 2/25/10 PKD
- +1 IF $GET(^BARCOL(DUZ(2),BARTX(14,"I"),1,BARTX(15,"I"),7,0))=""
- QUIT
- +2 KILL DIR
- +3 WRITE !!,?31,"**Messages Exist**",!
- +4 SET DIR("A")="Do you want them to print on the letter? "
- SET DIR("B")="YES"
- SET DIR(0)="YOA"
- +5 DO ^DIR
- +6 IF Y=1
- SET BARPRTQ=1
- +7 QUIT
- +8 ; ********************************************************************
- +9 ;THIS TABLE REPLICATES ^AUTTINTY INSURER TYPE (21 ENTRIES) P.OTT 4/12/2013
- +10 ;AND MAPS INSURER TYPE CODE TO CATEGORY (IE: W --> OTHER)
- H ;;PRIVATE INSURANCE;;HMO
- M ;;PRIVATE INSURANCE;;MEDICARE SUPPL.
- D ;;MEDICAID;;MEDICAID FI
- R ;;MEDICARE;;MEDICARE FI
- P ;;PRIVATE INSURANCE;;PRIVATE INSURANCE
- W ;;OTHER;;WORKMEN'S COMP
- C ;;OTHER;;CHAMPUS
- N ;;OTHER;;NON-BENEFICIARY (NON-INDIAN)
- I ;;OTHER;;INDIAN PATIENT
- K ;;MEDICAID;;CHIP (KIDSCARE)
- T ;;OTHER;;THIRD PARTY LIABILITY
- G ;;OTHER;;GUARANTOR
- MD ;;MEDICARE;;MCR PART D
- MH ;;MEDICARE;;MEDICARE HMO
- MMC ;;MEDICARE;;MCR MANAGED CARE
- TSI ;;OTHER;;TRIBAL SELF INSURED
- SEP ;;OTHER;;STATE EXCHANGE PLAN
- FPL ;;MEDICAID;;FPL 133 PERCENT
- MC ;;MEDICARE;;MCR PART C
- F ;;PRIVATE INSURANCE;;FRATERNAL ORGANIZATION
- V ;;VETERAN;;VETERANS MEDICAL BENEFITS
- +1 ;;***END OF TABLE**
