BARCHKLU ; IHS/SD/LSL - Look up Collection Information for Insurance Company by Check Number ;
;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
;
; IHS/SD/LSL - 11/14/02 - V1.7 - NOIS XCA-0802-200093
; Modify code that $O thru the "D" x-ref to check for checks
; in all upper case if check entered in lower case and lower case
; check fails.
;
; ********************************************************************
;
;** Collection Batch information by check number
;** option Check Posting Summary (CPS)**
;
ONE ;EP
N DIC,BARCHKNO,BARCBDA,BARITMNO
;
; -------------------------------
ASK W !!
S DIC=$$DIC^XBDIQ1(90051.01)
S DIC(0)="AEQZ"
S D="D"
S DIC("A")="Select Check Number: "
D IX^DIC
I X=" " W !," Must enter a Check Number " G ASK
Q:+Y<0
S BARCHKNO=X
S BARCBDA=+Y
S BARITMNO=0
S BARCBNM=$P(Y,U,2)
S BARITMNO=$O(^BARCOL(DUZ(2),"D",BARCHKNO,BARCBDA,BARITMNO))
I BARITMNO="" D I BARITMNO="" K BARCBDA,BARITMNO,BARCHKNO G ASK
. S BARCHKNO=$$UPC^BARUTL(X)
. S BARCBDA=+Y
. S BARITMNO=0
. S BARITMNO=$O(^BARCOL(DUZ(2),"D",BARCHKNO,BARCBDA,BARITMNO))
. I BARITMNO="" W !,"Couldn't find ITEM for this CHECK NUMBER. Please select again."
I '$D(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,0)) D G ASK
. W !,"PROBLEM WITH THIS ITEM SET UP CONTACT YOUR SUPPORT PERSONNEL"
. K BARCBDA,BARITMNO,BARCHKNO
I '$D(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,1)) D G ASK
. W !,"PROBLEM WITH THIS ITEM SET UP CONTACT YOUR SUPPORT PERSONNEL"
. K BARCBDA,BARITMNO,BARCHKNO
I '$D(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,2)) D G ASK
. W !,"PROBLEM WITH THIS ITEM SET UP CONTACT YOUR SUPPORT PERSONNEL"
. K BARCBDA,BARITMNO,BARCHKNO
S (BARCKAMT,BARINSNM,BARITMPD,BARITMBL,BARITMUD,BARITMUA,BARITMRF)=0
S BARCKAMT=$P(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,1),"^")
S BARINSNM=$P(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,2),"^")
S BARITMPD=$$VAL^XBDIQ1(90051.1101,"BARCBDA,BARITMNO",18)
S BARITMBL=$$VAL^XBDIQ1(90051.1101,"BARCBDA,BARITMNO",19)
S BARITMUD=$P(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,1),"^",3)
S BAR23=1
S BARITMUA=$$ITT^BARCBC(BARCBDA,BARITMNO,"UN-ALLOCATED")
K BAR23
S BARITMRF=$$ITT^BARCBC(BARCBDA,BARITMNO,"REFUND")*-1
W !,"Check No: ",BARCHKNO,?25,"From: ",$E(BARINSNM,1,30),?65,"For: ",$J(BARCKAMT,10,2),!
K DIR
S DIR(0)="Y"
S DIR("A")=" CORRECT "
S DIR("B")="YES"
D ^DIR
K DIR
I Y'=1 G ASK
D PRINT
Q
; *********************************************************************
;
I IOSL=6000 D
.W $$EN^BARVDF("IOF")
.W !?5,"Collection Batch: ",BARCBNM
.W ?50,"Item Number: ",BARITMNO
.W !,"Check Number: ",BARCHKNO
.W ?32,"Issued By: ",BARINSNM
.W !,"Check Amount: ",$J(BARCKAMT,10,2)
.W ?27,"Amount Posted : ",$J(BARITMPD,10,2)
.W ?55,"Balance : ",$J(BARITMBL,10,2)
.W !,"Un-Allocated: ",$J(BARITMUA,10,2)
.W ?55,"Refunded: ",$J(BARITMRF,10,2),!
.W !,"Patient Name",?19,"3P Bill DT",?30,"Bill Name",?48,"DOS",?70,"Paid Amt.",!
.D EBARPG
I IOSL<6000 D BARHDR
;
; -------------------------------
DETAILS ;
; Collect information on what bills this check applied to
S BARBCNT=0
S (BARDTTM,BARCHKPD)=0
F S BARDTTM=$O(^BARTR(DUZ(2),"AD",BARCBDA,BARDTTM)) Q:BARDTTM'>0 D Q:($G(DIROUT)!$G(DUOUT)!$G(DTOUT)!$G(DROUT))
.I $P(^BARTR(DUZ(2),BARDTTM,0),"^",15)'=BARITMNO Q
.I '$D(^BARTR(DUZ(2),BARDTTM,1)) Q
.I $P(^BARTR(DUZ(2),BARDTTM,1),"^")'=40 Q
.S (BARBLDA,BARBLPT,BARPDAMT)=0
.S (BARBLNM,BARBLPTN)=""
.S BARPDAMT=$P(^BARTR(DUZ(2),BARDTTM,0),U,2)
.S BARBLDA=$P(^BARTR(DUZ(2),BARDTTM,0),U,4)
.S BARBLPT=$P(^BARTR(DUZ(2),BARDTTM,0),U,5)
.S BARBLPTN=$E($$VAL^XBDIQ1(90050.01,BARBLDA,101),1,25)
.S BARDOSB=$$VALI^XBDIQ1(90050.01,BARBLDA,102)
.S BARDOSE=$$VALI^XBDIQ1(90050.01,BARBLDA,103)
.S BARDOSEF=$$SDT^BARDUTL(BARDOSE)
.S BARDOSBF=$$SDT^BARDUTL(BARDOSB) ;Y2000
.S BARBLNM=$E($$VAL^XBDIQ1(90050.01,BARBLDA,.01),1,15)
.S BAR3PAP=$$SDT^BARDUTL($P($G(^BARBL(DUZ(2),BARBLDA,0)),U,18))
.W !,$E(BARBLPTN,1,18)
.W ?19,BAR3PAP
.W ?30,$E(BARBLNM,1,17)
.W ?48,BARDOSBF_"-"_BARDOSEF
.W ?70,$J(BARPDAMT,10,2)
.S BARBCNT=BARBCNT+1
.S BARCHKPD=BARCHKPD+BARPDAMT
.D PG
.Q
W !!?40,"Bill Count: ",BARBCNT,?60,"TOTALS:",?68,$J(BARCHKPD,12,2),!
D EBARPG
I $E(IOST)="C",IOT["TRM" D EOP^BARUTL(0)
Q
; *********************************************************************
;
PRINT ;**Print
;
; GET DEVICE (QUEUEING ALLOWED)
S Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1)
K DA
Q:$D(DIRUT)
I Y="B" D Q
. S XBFLD("BROWSE")=1
. S BARIOSL=IOSL
. S IOSL=600
. D VIEWR^XBLM("HEADER^BARCHKLU")
. D FULL^VALM1
. W $$EN^BARVDF("IOF")
.D CLEAR^VALM1 ;clears out all list man stuff
.K XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF
.K VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMLFT,VALMLST,VALMMENU,VALMSGR
.K VALMUP,VALMWD,VALMY,XQORS,XQORSPEW,VALMCOFF
.;
.; ------------------------------
DEVE .;
.S IOSL=BARIOSL
.K BARIOSL
.Q
S XBRP="HEADER^BARCHKLU"
S XBNS="BAR"
S XBRX="EXIT^BARCHKLU"
D ^XBDBQUE
ENDJOB Q
; *********************************************************************
PG ;**page controller
BARPG ;EP PAGE CONTROLLER
; This utility uses variables BARPG("HDR"),BARPG("DT"),BARPG("LINE"),BARPG("PG")
; kill variables by D EBARPG
;
Q:($Y<(IOSL-6))!($G(DOUT)!$G(DFOUT))
S:'$D(BARPG("PG")) BARPG("PG")=0
S BARPG("PG")=BARPG("PG")+1
I $E(IOST)="C",IOT["TRM" D EOP^BARUTL(0) Q:($G(DIROUT)!$G(DUOUT)!$G(DTOUT)!$G(DROUT))
;
; -------------------------------
Q ;
Q:($G(DIROUT)!$G(DUOUT)!$G(DTOUT)!$G(DROUT))
;
; -------------------------------
BARHDR ; Write the Report Header
S BARPG("HDR")="Check Posting Summary"
W:$Y @IOF
W !
Q:'$D(BARPG("HDR"))
S:'$D(BARPG("LINE")) $P(BARPG("LINE"),"-",IOM-2)=""
S:'$D(BARPG("PG")) BARPG("PG")=1
I '$D(BARPG("DT")) D
. S %H=$H
. D YX^%DTC
. S BARPG("DT")=Y
U IO
W ?(IOM-$L(BARPG("HDR"))/2),BARPG("HDR")
W !?(IOM-75),BARPG("DT"),?(IOM-15),"PAGE: ",BARPG("PG")
W !,BARPG("LINE")
;
; -------------------------------
BARHD ;EP
; Write column header / message
W !?5,"Collection Batch: ",BARCBNM
W ?50,"Item Number: ",BARITMNO
W !,"Check Number: ",BARCHKNO
W ?32,"Issued By: ",BARINSNM
W !,"Check Amount: ",$J(BARCKAMT,10,2)
W ?27,"Amount Posted : ",$J(BARITMPD,10,2)
W ?55,"Balance : ",$J(BARITMBL,10,2),!
W "Un-Allocated: ",$J(BARITMUA,10,2)
W ?55,"Refunded: ",$J(BARITMRF,10,2),!
W !,"Patient Name"
W ?19,"3P Bill DT"
W ?30,"Bill Name"
W ?48,"DOS"
W ?70,"Paid Amt.",!
I ($G(DIROUT)!$G(DUOUT)!$G(DTOUT)!$G(DROUT)) S BARQUIT=1
Q
; *********************************************************************
;
EBARPG ;
K BARPG("LINE"),BARPG("PG"),BARPG("HDR"),BARPG("DT")
Q
; *********************************************************************
;
EXIT ; Exit routine
Q
BARCHKLU ; IHS/SD/LSL - Look up Collection Information for Insurance Company by Check Number ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
+2 ;
+3 ; IHS/SD/LSL - 11/14/02 - V1.7 - NOIS XCA-0802-200093
+4 ; Modify code that $O thru the "D" x-ref to check for checks
+5 ; in all upper case if check entered in lower case and lower case
+6 ; check fails.
+7 ;
+8 ; ********************************************************************
+9 ;
+10 ;** Collection Batch information by check number
+11 ;** option Check Posting Summary (CPS)**
+12 ;
ONE ;EP
+1 NEW DIC,BARCHKNO,BARCBDA,BARITMNO
+2 ;
+3 ; -------------------------------
ASK WRITE !!
+1 SET DIC=$$DIC^XBDIQ1(90051.01)
+2 SET DIC(0)="AEQZ"
+3 SET D="D"
+4 SET DIC("A")="Select Check Number: "
+5 DO IX^DIC
+6 IF X=" "
WRITE !," Must enter a Check Number "
GOTO ASK
+7 IF +Y<0
QUIT
+8 SET BARCHKNO=X
+9 SET BARCBDA=+Y
+10 SET BARITMNO=0
+11 SET BARCBNM=$PIECE(Y,U,2)
+12 SET BARITMNO=$ORDER(^BARCOL(DUZ(2),"D",BARCHKNO,BARCBDA,BARITMNO))
+13 IF BARITMNO=""
Begin DoDot:1
+14 SET BARCHKNO=$$UPC^BARUTL(X)
+15 SET BARCBDA=+Y
+16 SET BARITMNO=0
+17 SET BARITMNO=$ORDER(^BARCOL(DUZ(2),"D",BARCHKNO,BARCBDA,BARITMNO))
+18 IF BARITMNO=""
WRITE !,"Couldn't find ITEM for this CHECK NUMBER. Please select again."
End DoDot:1
IF BARITMNO=""
KILL BARCBDA,BARITMNO,BARCHKNO
GOTO ASK
+19 IF '$DATA(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,0))
Begin DoDot:1
+20 WRITE !,"PROBLEM WITH THIS ITEM SET UP CONTACT YOUR SUPPORT PERSONNEL"
+21 KILL BARCBDA,BARITMNO,BARCHKNO
End DoDot:1
GOTO ASK
+22 IF '$DATA(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,1))
Begin DoDot:1
+23 WRITE !,"PROBLEM WITH THIS ITEM SET UP CONTACT YOUR SUPPORT PERSONNEL"
+24 KILL BARCBDA,BARITMNO,BARCHKNO
End DoDot:1
GOTO ASK
+25 IF '$DATA(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,2))
Begin DoDot:1
+26 WRITE !,"PROBLEM WITH THIS ITEM SET UP CONTACT YOUR SUPPORT PERSONNEL"
+27 KILL BARCBDA,BARITMNO,BARCHKNO
End DoDot:1
GOTO ASK
+28 SET (BARCKAMT,BARINSNM,BARITMPD,BARITMBL,BARITMUD,BARITMUA,BARITMRF)=0
+29 SET BARCKAMT=$PIECE(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,1),"^")
+30 SET BARINSNM=$PIECE(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,2),"^")
+31 SET BARITMPD=$$VAL^XBDIQ1(90051.1101,"BARCBDA,BARITMNO",18)
+32 SET BARITMBL=$$VAL^XBDIQ1(90051.1101,"BARCBDA,BARITMNO",19)
+33 SET BARITMUD=$PIECE(^BARCOL(DUZ(2),BARCBDA,1,BARITMNO,1),"^",3)
+34 SET BAR23=1
+35 SET BARITMUA=$$ITT^BARCBC(BARCBDA,BARITMNO,"UN-ALLOCATED")
+36 KILL BAR23
+37 SET BARITMRF=$$ITT^BARCBC(BARCBDA,BARITMNO,"REFUND")*-1
+38 WRITE !,"Check No: ",BARCHKNO,?25,"From: ",$EXTRACT(BARINSNM,1,30),?65,"For: ",$JUSTIFY(BARCKAMT,10,2),!
+39 KILL DIR
+40 SET DIR(0)="Y"
+41 SET DIR("A")=" CORRECT "
+42 SET DIR("B")="YES"
+43 DO ^DIR
+44 KILL DIR
+45 IF Y'=1
GOTO ASK
+46 DO PRINT
+47 QUIT
+48 ; *********************************************************************
+49 ;
+1 IF IOSL=6000
Begin DoDot:1
+2 WRITE $$EN^BARVDF("IOF")
+3 WRITE !?5,"Collection Batch: ",BARCBNM
+4 WRITE ?50,"Item Number: ",BARITMNO
+5 WRITE !,"Check Number: ",BARCHKNO
+6 WRITE ?32,"Issued By: ",BARINSNM
+7 WRITE !,"Check Amount: ",$JUSTIFY(BARCKAMT,10,2)
+8 WRITE ?27,"Amount Posted : ",$JUSTIFY(BARITMPD,10,2)
+9 WRITE ?55,"Balance : ",$JUSTIFY(BARITMBL,10,2)
+10 WRITE !,"Un-Allocated: ",$JUSTIFY(BARITMUA,10,2)
+11 WRITE ?55,"Refunded: ",$JUSTIFY(BARITMRF,10,2),!
+12 WRITE !,"Patient Name",?19,"3P Bill DT",?30,"Bill Name",?48,"DOS",?70,"Paid Amt.",!
+13 DO EBARPG
End DoDot:1
+14 IF IOSL<6000
DO BARHDR
+15 ;
+16 ; -------------------------------
DETAILS ;
+1 ; Collect information on what bills this check applied to
+2 SET BARBCNT=0
+3 SET (BARDTTM,BARCHKPD)=0
+4 FOR
SET BARDTTM=$ORDER(^BARTR(DUZ(2),"AD",BARCBDA,BARDTTM))
IF BARDTTM'>0
QUIT
Begin DoDot:1
+5 IF $PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",15)'=BARITMNO
QUIT
+6 IF '$DATA(^BARTR(DUZ(2),BARDTTM,1))
QUIT
+7 IF $PIECE(^BARTR(DUZ(2),BARDTTM,1),"^")'=40
QUIT
+8 SET (BARBLDA,BARBLPT,BARPDAMT)=0
+9 SET (BARBLNM,BARBLPTN)=""
+10 SET BARPDAMT=$PIECE(^BARTR(DUZ(2),BARDTTM,0),U,2)
+11 SET BARBLDA=$PIECE(^BARTR(DUZ(2),BARDTTM,0),U,4)
+12 SET BARBLPT=$PIECE(^BARTR(DUZ(2),BARDTTM,0),U,5)
+13 SET BARBLPTN=$EXTRACT($$VAL^XBDIQ1(90050.01,BARBLDA,101),1,25)
+14 SET BARDOSB=$$VALI^XBDIQ1(90050.01,BARBLDA,102)
+15 SET BARDOSE=$$VALI^XBDIQ1(90050.01,BARBLDA,103)
+16 SET BARDOSEF=$$SDT^BARDUTL(BARDOSE)
+17 ;Y2000
SET BARDOSBF=$$SDT^BARDUTL(BARDOSB)
+18 SET BARBLNM=$EXTRACT($$VAL^XBDIQ1(90050.01,BARBLDA,.01),1,15)
+19 SET BAR3PAP=$$SDT^BARDUTL($PIECE($GET(^BARBL(DUZ(2),BARBLDA,0)),U,18))
+20 WRITE !,$EXTRACT(BARBLPTN,1,18)
+21 WRITE ?19,BAR3PAP
+22 WRITE ?30,$EXTRACT(BARBLNM,1,17)
+23 WRITE ?48,BARDOSBF_"-"_BARDOSEF
+24 WRITE ?70,$JUSTIFY(BARPDAMT,10,2)
+25 SET BARBCNT=BARBCNT+1
+26 SET BARCHKPD=BARCHKPD+BARPDAMT
+27 DO PG
+28 QUIT
End DoDot:1
IF ($GET(DIROUT)!$GET(DUOUT)!$GET(DTOUT)!$GET(DROUT))
QUIT
+29 WRITE !!?40,"Bill Count: ",BARBCNT,?60,"TOTALS:",?68,$JUSTIFY(BARCHKPD,12,2),!
+30 DO EBARPG
+31 IF $EXTRACT(IOST)="C"
IF IOT["TRM"
DO EOP^BARUTL(0)
+32 QUIT
+33 ; *********************************************************************
+34 ;
PRINT ;**Print
+1 ;
+2 ; GET DEVICE (QUEUEING ALLOWED)
+3 SET Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1)
+4 KILL DA
+5 IF $DATA(DIRUT)
QUIT
+6 IF Y="B"
Begin DoDot:1
+7 SET XBFLD("BROWSE")=1
+8 SET BARIOSL=IOSL
+9 SET IOSL=600
+10 DO VIEWR^XBLM("HEADER^BARCHKLU")
+11 DO FULL^VALM1
+12 WRITE $$EN^BARVDF("IOF")
+13 ;clears out all list man stuff
DO CLEAR^VALM1
+14 KILL XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF
+15 KILL VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMLFT,VALMLST,VALMMENU,VALMSGR
+16 KILL VALMUP,VALMWD,VALMY,XQORS,XQORSPEW,VALMCOFF
+17 ;
+18 ; ------------------------------
DEVE ;
+1 SET IOSL=BARIOSL
+2 KILL BARIOSL
+3 QUIT
End DoDot:1
QUIT
+4 SET XBRP="HEADER^BARCHKLU"
+5 SET XBNS="BAR"
+6 SET XBRX="EXIT^BARCHKLU"
+7 DO ^XBDBQUE
ENDJOB QUIT
+1 ; *********************************************************************
PG ;**page controller
BARPG ;EP PAGE CONTROLLER
+1 ; This utility uses variables BARPG("HDR"),BARPG("DT"),BARPG("LINE"),BARPG("PG")
+2 ; kill variables by D EBARPG
+3 ;
+4 IF ($Y<(IOSL-6))!($GET(DOUT)!$GET(DFOUT))
QUIT
+5 IF '$DATA(BARPG("PG"))
SET BARPG("PG")=0
+6 SET BARPG("PG")=BARPG("PG")+1
+7 IF $EXTRACT(IOST)="C"
IF IOT["TRM"
DO EOP^BARUTL(0)
IF ($GET(DIROUT)!$GET(DUOUT)!$GET(DTOUT)!$GET(DROUT))
QUIT
+8 ;
+9 ; -------------------------------
Q ;
+1 IF ($GET(DIROUT)!$GET(DUOUT)!$GET(DTOUT)!$GET(DROUT))
QUIT
+2 ;
+3 ; -------------------------------
BARHDR ; Write the Report Header
+1 SET BARPG("HDR")="Check Posting Summary"
+2 IF $Y
WRITE @IOF
+3 WRITE !
+4 IF '$DATA(BARPG("HDR"))
QUIT
+5 IF '$DATA(BARPG("LINE"))
SET $PIECE(BARPG("LINE"),"-",IOM-2)=""
+6 IF '$DATA(BARPG("PG"))
SET BARPG("PG")=1
+7 IF '$DATA(BARPG("DT"))
Begin DoDot:1
+8 SET %H=$HOROLOG
+9 DO YX^%DTC
+10 SET BARPG("DT")=Y
End DoDot:1
+11 USE IO
+12 WRITE ?(IOM-$LENGTH(BARPG("HDR"))/2),BARPG("HDR")
+13 WRITE !?(IOM-75),BARPG("DT"),?(IOM-15),"PAGE: ",BARPG("PG")
+14 WRITE !,BARPG("LINE")
+15 ;
+16 ; -------------------------------
BARHD ;EP
+1 ; Write column header / message
+2 WRITE !?5,"Collection Batch: ",BARCBNM
+3 WRITE ?50,"Item Number: ",BARITMNO
+4 WRITE !,"Check Number: ",BARCHKNO
+5 WRITE ?32,"Issued By: ",BARINSNM
+6 WRITE !,"Check Amount: ",$JUSTIFY(BARCKAMT,10,2)
+7 WRITE ?27,"Amount Posted : ",$JUSTIFY(BARITMPD,10,2)
+8 WRITE ?55,"Balance : ",$JUSTIFY(BARITMBL,10,2),!
+9 WRITE "Un-Allocated: ",$JUSTIFY(BARITMUA,10,2)
+10 WRITE ?55,"Refunded: ",$JUSTIFY(BARITMRF,10,2),!
+11 WRITE !,"Patient Name"
+12 WRITE ?19,"3P Bill DT"
+13 WRITE ?30,"Bill Name"
+14 WRITE ?48,"DOS"
+15 WRITE ?70,"Paid Amt.",!
+16 IF ($GET(DIROUT)!$GET(DUOUT)!$GET(DTOUT)!$GET(DROUT))
SET BARQUIT=1
+17 QUIT
+18 ; *********************************************************************
+19 ;
EBARPG ;
+1 KILL BARPG("LINE"),BARPG("PG"),BARPG("HDR"),BARPG("DT")
+2 QUIT
+3 ; *********************************************************************
+4 ;
EXIT ; Exit routine
+1 QUIT
