4:28 PM 17-JAN-96 ABPAALK1 ABPAALK1 ; IHS/ADC/CRG - BATCH STATISTICAL LISTING REPORT ; [ 01/17/96 9:21 AM ] ;;1.5;AO 3P BILLING TRACKING;**6**;JAN 10, 1996 ;Patch #6 -- Had to rewrite this entire report since there were too ;many bugs to fix and keep the same logic. IHS/ADC/CRG 1/11/96 START ;EP ; D INIT D LOOKUP I $G(ABPAQFLG)=1 G XIT Q D DEV I $G(ABPAQFLG)=1 G XIT Q D DATA F I=1:1:(IOSL-2-$Y) W ! S DIR(0)="E" D ^DIR Q INIT ;Initialization D XIT S ABPAQFLG=0 S $P(ABPAX,"-",80)="" S $P(ABPAXX,"=",80)="" S ABPA("HD",1)=ABPATLE S ABPA("HD",2)="Display ALL Patient TRANSACTIONS" D ^ABPAHD Q LOOKUP ;Lookup on area tracking patient file ; N DIC S DIC="^ABPVAO(",DIC(0)="AEMQZ",DIC("A")="Select PATIENT: " D ^DIC I $D(DTOUT) S ABPAQFLG=1 Q I $D(DUOUT) S ABPAQFLG=1 Q I Y<0 G LOOKUP S ABPAPAT=Y(0,0),ABPATDFN=+Y Q DATA ;Data D HDR F ABPACLMS="O","PE","PA","C" D .S ABPC="" F S ABPC=$O(^ABPVAO("CS",ABPACLMS,ABPATDFN,ABPC)) Q:ABPC="" D DETAIL D:ABPS="PA"!(ABPS="C") PAY D:$D(IO("S")) ^%ZISC Q DETAIL ;Output -- save pat. data to temp--write bill id, insurer, ;Date of service, claim amount, status of claim ; I ($Y+6>IOSL),($E(IOST)="C") S DIR(0)="E" D ^DIR D:$Y+6>IOSL HDR S ABP("TMP")=^ABPVAO(ABPATDFN,1,ABPC,0) W !,$J($P(ABP("TMP"),U,2),6) W ?7,$E($P($G(^AUTNINS(+$P(ABP("TMP"),U,6),0)),U),1,15) W ?23,$$EP^ABPDTCV(+ABP("TMP")) W ?31,$J($P(ABP("TMP"),U,7),8,2) S ABPS=$P(ABP("TMP"),U,17) W ?43,$S(ABPS="C":"CLOSED",ABPS="D":"DENIED",ABPS="PA":"PAID",ABPS="PE":"PENDING",ABPS="O":"OPEN",1:"???") Q PAY ;Payment info from paid and closed status records get payment date from ;"D" subscript and payment amount from "A" subscript ; S (ABPAMT,ABPTAMT)=0 S R=0 F S R=$O(^ABPVAO(ABPATDFN,"P",ABPC,"D",R)) Q:+R=0 D .W:R>1 ! W ?52,$$EP^ABPDTCV($P($G(^ABPVAO(ABPATDFN,"P",ABPC,"D",R,0)),U)) .S J=0 F S J=$O(^ABPVAO(ABPATDFN,"P",ABPC,"A",J)) Q:+J=0 D ..S ABPAMT=$P($G(^ABPVAO(ABPATDFN,"P",ABPC,"A",J,0)),U) ..W:J>1 ! ..W ?64,$P($G(^ABPVAO(ABPATDFN,"P",ABPC,"A",J,0)),U) ..W ?73,"(",$P($G(^ABPVAO(ABPATDFN,"P",ABPC,"A",J,0)),U,2),")" ..I ($Y+6>IOSL),($E(IOST)="C") S DIR(0)="E" D ^DIR ..D:$Y+6>IOSL HDR ..S ABPTAMT=ABPTAMT+ABPAMT W:ABPTAMT>ABPAMT !,?64,"--------",!?64,ABPTAMT,! Q HDR ; W @IOF W !,ABPATLE," - ",ABPAHD1 W !,ABPAXX W !,ABPAPAT," ",ABPAOPT(3) W !,ABPAXX W !," Bill",?10,"Insurance",?23,"Date of",?33,"Claim",?43,"Claim",?51,"Dates of",?63,"Payment",?72,"Payment" W !," id",?10,"Company",?23,"Service",?33,"Amount",?43,"Status",?51,"Service",?63,"Amount",?72,"Type" W !,ABPAX F I=1:1:80 W " " Q XIT ; K ABPA,ABP,ABPC,ABPS,ABPAX,ABPAXX,ABPACLMS,ABPATDFN,R,J Q DEV ;Get device S %ZIS="NQ" D ^%ZIS I IO'=IO(0) D QUE,HOME^%ZIS S ABPAQFLG=1 Q I $D(IO("S")) S IOP=ION,$P(IOP,";",2)=IOST,$P(IOP,";",3)=IOM,$P(IOP,";",4)=IOSL D ^%ZIS Q QUE ; S ZTRTN="DATA^ABPAALK1" S ZTDESC="PATIENT TRANSACTION DISPLAY" S ZTSAVE("ABPAPAT")="",ZTSAVE("ABPATDFN")="",ZTSAVE("ABPAX")="",ZTSAVE("ABPAXX")="" S ZTDTH=$H K ZTSK D ^%ZTLOAD W:$G(ZTSK) !,"Task #",ZTSK," queued",! Q ABPAALK2 ABPAALK2 ; IHS/ADC/CRG - PRIV-INS ACCT DISPLAY UTILITY ; [ 01/11/96 3:25 PM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**3**;APR 18, 1994 N S START S R=0 F S R=$O(^ABPVAO(ABPATDFN,"P",R)) Q:+R=0 D .S (ABPA2R,ABPA3R,ABPA("CTOT"),ABPA("PTOT"),ABPA("CCNT"),ABPA("ACNT"))=0 W ! .F ABPARR=1:1 D Q:+ABPA2R=0 ..S ABPA2R=$O(^ABPVAO(ABPATDFN,"P",R,"D",ABPA2R)) ..I +ABPA2R=0 D AMT Q:+ABPA3R=99!(+ABPA("CCNT")'>1&(+ABPA("ACNT")'>1)) D TOTAL Q ..S ABPA("CCNT")=ABPA("CCNT")+1 ..S ABPAC=$P(^ABPVAO(ABPATDFN,"P",R,"D",ABPA2R,0),"^",2) ..Q:$D(^ABPVAO(ABPATDFN,1,ABPAC,0))'=1 D DT3 S ABPAI=ABPAI+1 ..I ABPARR=1 D PDATE ..S ABPA3R=$O(^ABPVAO(ABPATDFN,"P",R,"A",ABPA3R)) ..I +ABPA3R>0 S ABPA("ACNT")=ABPA("ACNT")+1 W:$X>62 ! ..I +ABPA3R<1 S ABPA3R=99 ..I $Y>21&(IO=IO(0)) D RESET Q ..I $Y>55 W @IOF QUIT Q ; DT3 S Y=^ABPVAO(DA,1,ABPAC,0),ABPA(ABPAI)=+Y S ABPAINS=$E($P($G(^AUTNINS($P(Y,U,6),0)),U),1,15) W !,$J(ABPAI,3),?5,$J("",14-$L(ABPAINS)\2)_ABPAINS,?22 W $J((+$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_+$E(Y,2,3)),8),?33 W $J($P(Y,U,7),8,2) S ABPA("CTOT")=ABPA("CTOT")+(+$P(Y,U,7)) S S=$P(Y,U,17) W ?43,$S(S="C":"CLOSED",S="D":"DENIED",S="PA":"PAID",S="PE":"PENDING",S="O":"OPEN",1:"??????") Q ; AMT ;Amount of payment ; S ABPA("PTOT")=0 F ABPA3R=0:0 D Q:+ABPA3R=0!(+ABPA3R=99) .S ABPA3R=$O(^ABPVAO(ABPATDFN,"P",R,"A",ABPA3R)) Q:+ABPA3R=0 .S ABPA("ACNT")=ABPA("ACNT")+1 .W ?50,$J(ABPAPDT,10) .W:$X>62 ! W ?62,$J(+^ABPVAO(DA,"P",R,"A",ABPA3R,0),10,2) .S ABPA("PTOT")=ABPA("PTOT")+(+^ABPVAO(DA,"P",R,"A",ABPA3R,0)) .W " (",$P(^ABPVAO(DA,"P",R,"A",ABPA3R,0),"^",2),")" .I $Y>21&(IO=IO(0)) D Q ..S R=R-1,ABPA2R="",ABPA3R=99,ABPAI=ABPAI-1 ..R !,?20,"< Press 'RETURN' to Continue, or '^' to Exit >",X:300 ..I '$T!(X="^") S R="" Q ..D ^ABPAALK3 .I $Y>55 W @IOF Q PDATE ;PAYMENT DATE ; S ABPATDT=+^ABPVAO(DA,"P",R,0) S ABPAPDT=+$E(ABPATDT,4,5)_"/"_+$E(ABPATDT,6,7)_"/"_+$E(ABPATDT,2,3) K ABPATDT Q ; TOTAL ;CLAIM AND PAYMENT TOTALS ; W !?33,"--------",?64,"--------" W !?33,$J(ABPA("CTOT"),8,2),?64,$J(ABPA("PTOT"),8,2) Q ; RESET ;RESET COUNTERS ; I +ABPA3R<99 D COUNT S ABPA("CTOT")=ABPA("CTOT")-(+$P(^ABPVAO(DA,1,ABPAC,0),"^",7)) S ABPA("CCNT")=ABPA("CCNT")-1 S ABPA2R=ABPA2R-1,ABPA3R=ABPA3R-1,ABPAI=ABPAI-1,ABPARR=ABPARR-1 S:+ABPA2R=0 ABPA2R=.99 R !,?20,"< Press 'RETURN' to Continue, or '^' to Exit >",X:300 I '$T!(X="^") S R="",ABPA2R="" Q D ^ABPAALK3 Q ; COUNT ;RESET PAYMENT TOTAL AND AMOUNT COUNT ; S ABPA("PTOT")=ABPA("PTOT")-(+^ABPVAO(DA,"P",R,"A",ABPA3R,0)) S ABPA("ACNT")=ABPA("ACNT")-1 Q ABPAALK3 ABPAALK3 ; IHS/ADC/CRG - PVT INS ACCOUNT DISPLAY SUPPLEMENT ; STAMP ;;1.5;AO 3P BILLING TRACKING;**3**;APR 18, 1994 DTHD ;W @IOF S X=ABPATLE_" - Display ALL Patient TRANSACTIONS" ;W ?(40-($L(X)/2)),X,!,ABPAX,! ;W:IO=IO(0) @ABPARON W ABPAPAT_" ("_ABPAHRN_") "_$E(ABPAL,1,25) ;W:IO=IO(0) @ABPAROFF W !,"Other Names Used:" S ABPAZR=0 F I=0:0 D Q:+ABPAZR=0 .S ABPAZR=$O(^ABPVAO(ABPATDFN,"AKA",ABPAZR)) Q:+ABPAZR=0 .W:$X>20 ! W ?20,$P(^ABPVAO(ABPATDFN,"AKA",ABPAZR,0),"^")," (" .W:$P(^ABPVAO(ABPATDFN,"AKA",ABPAZR,0),"^",2)=1 "Alias)" .W:$P(^ABPVAO(ABPATDFN,"AKA",ABPAZR,0),"^",2)'=1 "Look-up only)" W !,ABPAX W !,"Bill",?8,"Insurance",?23,"Date of",?34,".....Claim.....",?53 W ".........Payment........",!?1,"Id",?8,"Company",?23,"Service" W ?34,"Amount",?43,"Status",?53,"Date(s)",?65,"Amount Type",!,ABPAXX Q ABPABLST ABPABLST ; IHS/ADC/CRG - PAYMENT BATCH STATISICAL LISTING ; [ 01/17/96 9:20 AM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**6**;JAN 10, 1996 ;Patch #6 -- Added new date module and added FLDS and BY variables. ;Patch #6 -- IHS/ADC/CRG-1/11/96 S ABPAHD1="Print PAYMENT BATCH STATISTICAL REPORT" D HEADER^ABPAMAIN ;D ^ABPADATE G:$D(ABPA9EDT)'=1 END ;S ABPA("DTIN")=ABPA9BDT D DTCVT^ABPAMAIN ;S ABPA("MONTHS")="12^01^02^03^04^05^06^07^08^09^10^11" ;S $E(ABPA9BDT,4,5)=$P(ABPA("MONTHS"),"^",+$E(ABPA9BDT,4,5)) ;S FR=$E(ABPA9BDT,1,5)_";"_ABPA("DTOUT") ;S ABPA("DTIN")=ABPA9EDT D DTCVT^ABPAMAIN ;S TO=$E(ABPA9EDT,1,5)_";"_ABPA("DTOUT") ;S L=0,DIC="^ABPAPBAT(",BY="[ABPA/BATCH/STATISTICS]" DATE ;**Select Date Range ; N DIR S DIR("A")="Enter Beginning date" S DIR(0)="D^" D ^DIR I Y<0!($D(DTOUT))!($D(DUOUT)) S ABPEFLG=1 Q S ABP("BDOS")=Y S FR=Y S ABP("XBDOS")=Y(0) N DIR S DIR("A")="Enter Ending date" S DIR("B")="NOW" S DIR(0)="D^"_Y_":NOW" D ^DIR I Y<0!($D(DTOUT))!($D(DUOUT)) S ABPEFLG=1 Q S ABP("EDOS")=Y S TO=Y S ABP("XEDOS")=Y(0) S L=0,DIC="^ABPAPBAT(",BY="]@DATE" S FLDS="NUMDATE(DATE);""DATE"",.05;R9&,12;R9&,11;R9&,(#.05+#12-#11);""ADJUSTED COLLECTIONS"";R9&,1;R9&,15;R9&" ;S DHD=ABPATLE_" - BATCH STATISTICS - "_$P(FR,";",2)_" to " ;S DHD=DHD_$P(TO,";",2),%ZIS("A")="Select DEVICE or [Q]ueue: " S DHD="PAYMENT BATCH STATISTICAL REPORT FOR: "_ABP("XBDOS")_" TO "_ABP("XEDOS") W ! D EN1^DIP D PAUSE^ABPAMAIN ;W !!!,"FROM AND TO:",FR,TO END K ABPA9BDT,DIC,ABPA9EDT,X,Y,FR,TO,L,BY,DHD,%ZIS("A") Q ABPABRC0 ABPABRC0 ; IHS/ADC/CRG - AUTO PAYMENT BATCH RE-CALCULATION ; [ 04/06/94 9:14 AM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**1,2**;SEP 17, 1992 ;Since this is the end of the payment posting process kill ^TMP( global K ^TMP($J,"ABPA") ;CALCULATE CURRENT PAYMENT CATEGORY AMOUNTS W !! D WAIT^DICD W !!,"Re-calculating the BATCH SUMMARIES" S (S,D,N,P,R,DA(2))=0,ABPABDT=+ABPABDFN F I=0:0 D Q:+DA(2)=0 .S DA(2)=$O(^ABPVAO("BD",ABPABDT,DA(2))) Q:+DA(2)=0 .S DA(1)=0 F I=0:0 D Q:+DA(1)=0 ..S DA(1)=$O(^ABPVAO("BD",ABPABDT,DA(2),DA(1))) Q:+DA(1)=0 ..Q:$D(^ABPVAO(DA(2),"P",DA(1),0))'=1 ..S ABPACHK("NUM")=$P(^ABPVAO(DA(2),"P",DA(1),0),"^",6) ..S DA=0 F I=0:0 D Q:+DA=0 ...S DA=$O(^ABPVAO(DA(2),"P",DA(1),"A",DA)) Q:+DA=0 ...Q:$D(^ABPVAO(DA(2),"P",DA(1),"A",DA,0))'=1 ...I +$P(^ABPVAO(DA(2),"P",DA(1),"A",DA,0),"^")<0 I ABPACHK("NUM")']"" D Q ....S R=R+(+^ABPVAO(DA(2),"P",DA(1),"A",DA,0)*-1) ...S ABPATYP=$P(^ABPVAO(DA(2),"P",DA(1),"A",DA,0),"^",2) Q:ABPATYP']"" Q:"SNDP"'[ABPATYP ...Q:ABPATYP="S"&(+^ABPVAO(DA(2),"P",DA(1),"A",DA,0)>0)&(ABPACHK("NUM")']"") ...S @ABPATYP=@ABPATYP+(+^ABPVAO(DA(2),"P",DA(1),"A",DA,0)) W "." S $P(^ABPAPBAT(ABPABDFN,0),"^",2)=+S S $P(^ABPAPBAT(ABPABDFN,0),"^",4)=+N S $P(^ABPAPBAT(ABPABDFN,0),"^",3)=+D S $P(^ABPAPBAT(ABPABDFN,0),"^",11)=+P S $P(^ABPAPBAT(ABPABDFN,0),"^",14)=+R K P F ABPAJ=2,10,12,13 S P(ABPAJ)=$P(^ABPAPBAT(ABPABDFN,0),"^",ABPAJ) S ABPABAL=((P(10)+P(13))-(P(12)+P(2))) S $P(^ABPAPBAT(ABPABDFN,0),"^",15)=+ABPABAL K DIC,X,Y,S,D,N,DA,I,P,R,ABPABDT,ABPATYP,ABPACHK("NUM"),ABPABAL Q CLOSE ;ENTRY POINT ;CHECK BALANCE OF THE PAYMENT BATCH K P F ABPAJ=2,10,12,13 S P(ABPAJ)=$P(^ABPAPBAT(ABPABDFN,0),"^",ABPAJ) I ((P(10)+P(13))-(P(12)+P(2)))=0 D .W !,"The current balance of this batch is $ 0.00" .K DIR S DIR(0)="Y",DIR("A")="DO YOU WANT TO CLOSE THIS BATCH" .S DIR("B")="NO" W *7 D ^DIR I 'Y W " ... Batch NOT Closed!" Q .I Y D W " ... Batch Closed!" ..S $P(^ABPAPBAT(ABPABDFN,0),"^",5)="C" ..S $P(^ABPAPBAT(ABPABDFN,0),"^",8)=DT ..S ^ABPAPBAT("AC",DT,ABPABDFN)="" ..S $P(^ABPAPBAT(ABPABDFN,0),"^",9)=DUZ ABPADC01 ABPADC01 ; IHS/ADC/CRG - CONVERT PAYMENT DATA TO v1.4 FORMAT ; [ 04/06/94 9:13 AM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**2**;SEP 17, 1992 W !!,"<< NOT AN ENTRY POINT - JOB ABORTED >>",!! Q BEGIN ;ENTRY POINT D SETUP H 2 D GETDATA,END Q SETUP ; S ABPA("C%")=.02,ABPA("CONVERT")="" I $D(ABPAROFF)'=1 D CRT^ABPAVAR S ABPA("PCNT")=$P(^ABPVAO(0),"^",4) Q:+ABPA("PCNT")'>0 F I=.02:.02:1 S ABPA(I,"%")=ABPA("PCNT")*I W !!?3,"Converting your payment data to the v1.4 format:",!!?6,"You " W "have ",ABPA("PCNT")," patient(s) in your database to process." W !!?6,"Starting time: " S %H=$H D YX^%DTC W $P(Y,"@",2),!! S X="Percentage of your database converted" W ?(40-($L(X)\2)),X,! W ?13,0 F I=10:10:100 W ?($X+3) W:I=10 " " W I W !?13,"|" F I=1:1:10 W "----|" F I=$X:-1:14 W @IOBS W:I=14 @ABPARON Q GETDATA ; S ABPA("RCT")=0,ABPATDFN=0 F D Q:+ABPATDFN=0 .S ABPATDFN=$O(^ABPVAO(ABPATDFN)) Q:+ABPATDFN=0 .S ABPA("RCT")=ABPA("RCT")+1,ABPADDFN=0 F D Q:+ABPADDFN=0 ..S ABPADDFN=$O(^ABPVAO(ABPATDFN,"P",ABPADDFN)) Q:+ABPADDFN=0 ..D KVARS S (ABPACAMT,ABPACCNT,ABPAOBAL,ABPATPD)=0 ..S (ABPATA2,ABPATA3,ABPATA4,ABPATA5,ABPATA7)=0 ..F C="N","D","S" S ABPA("UP",C)=0 ..S ABPAAPTR=0 F D Q:+ABPAAPTR=0 ...S ABPAAPTR=$O(^ABPVAO(ABPATDFN,"P",ABPADDFN,"A",ABPAAPTR)) ...Q:+ABPAAPTR=0 S X=^ABPVAO(ABPATDFN,"P",ABPADDFN,"A",ABPAAPTR,0) ...S ABPAPCOD=$P(X,"^",2) I ABPAPCOD]"" I "NDS"[ABPAPCOD D ....S ABPA("UP",ABPAPCOD)=ABPA("UP",ABPAPCOD)+(+X) ..S ABPADPTR=0 F D Q:+ABPADPTR=0 ...S ABPADPTR=$O(^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPADPTR)) ...Q:+ABPADPTR=0 ...S ABPADOS=+^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPADPTR,0) ...S DA=$P(^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPADPTR,0),"^",2) ...Q:$D(^ABPVAO(ABPATDFN,1,DA,0))'=1 D GETDAT ..D BEGIN^ABPAPD7A,CURARAY^ABPAPD7C S ABPA("Y")=3 D FILE^ABPAPD7 .I ABPA("RCT")'1 D UPDATE W @ABPAROFF,!!?6,"Ending time: " S %H=$H D YX^%DTC W $P(Y,"@",2),!! K ABPATDFN,ABPADDFN,ABPA KVARS ; K ABPACAMT,ABPACCNT,^TMP($J,"ABPA","HP"),^TMP($J,"ABPA","CP"),ABPA("PP"),ABPA("UP") K ABPAP1,ABPAP2,ABPAP3,ABPAP4,ABPAP5,ABPAP6,ABPAPTOT,ABPACDFN,ABPAY K ABPA("PB"),ABPA("NB"),ABPA("DB"),ABPA("SB"),ABPACTOB,ABPADOS K ABPACURB,ABPA("S$"),ABPA("N$"),ABPA("P$"),ABPA("D$"),ABPATCNT K ABPATBAL,ABPA("%"),ABPA("$"),ABPAD,ABPADATA,ABPAY,ABPAZ,ABPAZZ K ABPAT1,ABPAT2,ABPAT3,ABPAT4,ABPAT5,ABPAT6,ABPAH2,ABPAH3,ABPAH4 K ABPAH5,ABPACURA,ABPAAPTR,X,ABPAPCOD,ABPADPTR,DA,ABPAPTR Q ABPAOC0A ABPAOC0A ; IHS/ADC/CRG - OPEN UNIX HFS DEVICE ; [ 01/17/96 4:25 PM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**6**;JAN 10, 1996 ;Patch #6 - Replace I/O variable IOUPAR with IOPAR. IHS/ADC/CRG 1/11/96 ;CHECK FOR HOST COMMAND A0 S X="%HOSTCMD" X ^%ZOSF("TEST") I '$T W !!,"HOST COMMAND NOT PRESENT, UNABLE TO PROCEED" H 2 Q D DT^DICRW S:$D(ABPA("EFLG"))'=1 ABPA("EFLG")=0 S ABPA("CARTRIDGE")=0 W !!,"Get input from: [C]artridge or [F]ile F// " R X:DTIME I $T=0 D Q .S ABPA("EMSG")="<< INVALID OR NO DEVICE SELECTED - JOB ABORTED >>" .S ABPA("EFLG")=ABPA("EFLG")+1 I X="" S X="F" I (X'["C")&(X'["F") D Q .S ABPA("EMSG")="<< INVALID OR NO DEVICE SELECTED - JOB ABORTED >>" .S ABPA("EFLG")=ABPA("EFLG")+1 I X["C" S ABPA("CARTRIDGE")=1 ; CART I X["C" K %DEV,%IN S %FN=""_"/dev/rct"_"" D OPEN D Q .I +ABPA("EFLG")>0 D ..S ABPA("EMSG")="<< DEVICE UNAVAILABLE - JOB ABORTED >>",ABPA("EFLG")=ABPA("EFLG")+1 ; FILE W !! S ABPA("CMD")="cd /usr/spool/uucppublic; ls ABPV* | sort " S ABPA("CMD")=ABPA("CMD")_"> abpv.list; cd /usr/mumps" ;EXCEPTION APPROVED FOR HOST COMMAND -- DATE: APR 19, 1993 S X=$$TERMINAL^%HOSTCMD(ABPA("CMD")) K %DEV,%IN S %FN=""_"/usr/spool/uucppublic/abpv.list"_"" D OPEN I +ABPA("EFLG")>0 D Q .S ABPA("EMSG")="<< DEVICE UNAVAILABLE - JOB ABORTED >>",ABPA("EFLG")=ABPA("EFLG")+1 F I=1:1 U %DEV R X:DTIME Q:X="" S ABPAFILE(I)=X D ^%ZISC U IO(0) I $D(ABPAFILE(1))'=1 D Q .S ABPA("EMSG")="<< NO FILES AVAILABLE TO MERGE - JOB ABORTED >>" .S ABPA("EFLG")=ABPA("EFLG")+1 F I=1:1 Q:$D(ABPAFILE(I))'=1 W !?10,I,". ",ABPAFILE(I) SELECT W !!,"Select the FILE to use (""^"" to CANCEL)// " R X:DTIME I $T=0!(X["^")!(X="") D Q .S ABPA("EMSG")="<< NO FILE SELECTED - JOB ABORTED >>",ABPA("EFLG")=ABPA("EFLG")+1 S X=$S($D(ABPAFILE(X))=1:ABPAFILE(X),1:"INVALID SELECTION") W " ",X I X="INVALID SELECTION" G SELECT S %FN=""_"/usr/spool/uucppublic/"_X_"" K %DEV,%IN D OPEN D S:+ABPA("EFLG")'>0 IO=+%DEV Q .I +ABPA("EFLG")>0 D ..S ABPA("EMSG")="<< DEVICE UNAVAILABLE - JOB ABORTED >>",ABPA("EFLG")=ABPA("EFLG")+1 ; OPEN ;;VARIABLES USED FOR MSM HFS DEVICE OPEN UTILITY ;; %DEV -- DEVICE NUMBER, INITIALIZED TO 51 ;; %FN -- UNIX FILE NAME (USING FULL PATH NAME) ;; %IN -- OPEN PARAMETER (DEFAULT = 1 - READ ONLY) ;; %ZA -- RESULT CODE (-1 = ERROR) I ABPA("CARTRIDGE")=1 D Q:'POP .S %IS("A")="DEVICE TYPE: " .S %IS("B")="TAPE" .D ^%ZIS I POP W !,"DEVICE NOT PRESENT" K %DEV,%IN Q ;.S DIR(0)="N^0:200",DIR("A")="INPUT CARTRIDGE DEVICE NUMBER" ;.D ^DIR K DIR ;.I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) Q ;.S %DEV=Y S IOP=%DEV,%IS("IOUPAR")="("""_%FN_""":""R"")" D ^%ZIS ;.I POP W !,"NO DEVICE" K %DEV,%IN Q I ABPA("CARTRIDGE")=0 D Q:'POP .;F %DEV=51:1:54 S IOP=%DEV,%IS("IOUPAR")="("""_%FN_""":""R"")" D ^%ZIS Q:'POP ;IHS/ADC/CRG 1/11/96 .F %DEV=51:1:54 S IOP=%DEV,%ZIS("IOPAR")="("""_%FN_""":""R"")" D ^%ZIS Q:'POP ;IHS/ADC/CRG 1/11/96 .I POP W !,"NO DEVICE" K %DEV,%IN Q D ^%ZISC Q ABPAPD2B ABPAPD2B ; IHS/ADC/CRG - PVT-INS PYMT ENTRY CONTINUED ; [ 04/05/94 8:15 AM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**1**;SEP 17, 1992 DIC1 K DIC,DIE,DR,DA,%DT S DA(1)=ABPATDFN I $D(^ABPVAO(DA(1),"P",0))=0 D .S ^ABPVAO(DA(1),"P",0)="^9002270.22DA^^0" S DIC="^ABPVAO("_DA(1)_",""P"",",DIC(0)="LXZ" S X=ABPABDT D ^DIC I +$P(Y,U,3)=0 D G @ABPACONT .K ABPACONT .S X=""""_ABPABDT_"""" D ^DIC S ABPACONT="DIE1" DIE1 K DIC,DIE,DR,DA S ABPADDFN=+Y,DA(1)=ABPATDFN,DA=ABPADDFN S DIE="^ABPVAO("_DA(1)_",""P"",",DR="1///T;1.01///"_DUZ S DR=DR_";1.03///T;1.05///"_DUZ D ^DIE ;S:ABPAOPT(1)="Y" DR=DR_";.03" W ! D ^DIE F I=0:0 D Q:(ABPA9("GOTCHECK"))!(('ABPA9("GOTCHECK"))&((Y="")!(Y["^"))) W *7," ??" .D MAIN^ABPACKLK I ABPA9("GOTCHECK") D ..S DR=".05///"_ABPACHK("NUM") D ^DIE D ^ABPAPD2C ..S X=ABPACHK("RAMT") D COMMA^%DTC S Y=X ..S X="*** Check #"_ABPACHK("NUM")_" has a remaining balance of $" ..S X=X_Y_"***" W !?(40-($L(X)/2)),X Q I 'ABPA9("GOTCHECK") I Y'="" D G ^ABPAPD1 .W *7,!!?10,"NO CHECK SELECTED -- CANCELLING THIS ENTRY..." H 2 .S DIK="^ABPVAO("_DA(1)_",""P""," D ^DIK .L +^ABPVAO(ABPATDFN):5 I '$T W !!,"UNABLE TO LOCK ABPVAO FILE" H 2 G ^ABPAPD1 W ! I $D(^ABPVAO(ABPATDFN,"P",ABPADDFN,"A",0))=0 D .S ^ABPVAO(ABPATDFN,"P",ABPADDFN,"A",0)="^9002270.223A^^0" DIR K DIR,X,Y,ABPA("ANS") S DIR(0)="FO^2:15",DIR("A")=" PAYMENT AMOUNT" ;S DIR(0)="NO^1:99999:2",DIR("A")=" PAYMENT AMOUNT" S DIR("?",1)="Enter a dollar amount between .01 and 999999. You may " S DIR("?",1)=DIR("?",1)_"use the 'fast entry'" S DIR("?",2)="method if you wish by following the dollar amount with " S DIR("?",2)=DIR("?",2)_"the TYPE OF PAYMENT" S DIR("?",3)="(1:Standard 2:Deductible 3:Non-covered 4:Penalty) and " S DIR("?",3)=DIR("?",3)_"CLAIM ASSIGNMENT" S DIR("?",4)="separated by commas. For example, entering 20.13,2," S DIR("?",4)=DIR("?",4)_ABPACCNT_" creates a $20.13" S DIR("?",5)="deductible transaction assigned to the last claim " S DIR("?",5)=DIR("?",5)_"currently displayed.",DIR("?")=" " D ^DIR ;W !!,"Y: ",Y S ABPA("ANS")=Y I +Y=0 I $E(Y)'="""" K DA S Y=-1,DA(1)=ABPATDFN,DA=ABPADDFN G NOENT K DIC,DIE,DA,DR S DA(1)=ABPATDFN,DA=ABPADDFN,X=$P(ABPA("ANS"),",") S DIC="^ABPVAO("_DA(1)_",""P"","_DA_",""A"",",DIC(0)="LQ" D ^DIC NOENT I +Y<0&(+$P(^ABPVAO(DA(1),"P",DA,"A",0),"^",4)'>0) D G ^ABPAPD1 .W *7,!!?10,"NO PAYMENTS ENTERED -- CANCELLING THIS ENTRY..." H 2 .S DIK="^ABPVAO("_DA(1)_",""P""," D ^DIK .L +^ABPVAO(ABPATDFN):5 I '$T W !!,"UNABLE TO LOCK ABPVAO FILE" H 2 G ^ABPAPD1 G:+Y<0 DIE3 I +$P(Y,U,3)=0 D G DIR .W *7,!!?5,"You have already made an entry of this amount. If you" .W !?5,"need to make another entry of the same amount for a" .W !?5,"different type, please put quotes around the amount." .W !!?20,"i.e. ""48.23""" DIE2 K DIC,DIE,DA,DR S DA=+Y,DA(1)=ABPADDFN,DA(2)=ABPATDFN S DIE="^ABPVAO("_DA(2)_",""P"","_DA(1)_",""A"",",DIE("NO^")="" S DIE("W")="W !,$J($P(DQ(DQ),""^""),16),"": """ S DR="1//STANDARD" I $P(ABPA("ANS"),",",2)]"" D .Q:+$E($P(ABPA("ANS"),",",2))<1!(+$E($P(ABPA("ANS"),",",2))>4) .D @(+$E($P(ABPA("ANS"),",",2))) D ^DIE S ABPACOD=X K DIR I ABPACCNT=1 D G DIR .S DR="2///"_ABPA("C",1) D ^DIE S X=+$P(ABPA("ANS"),",",3) I X'>0 D .S DIR(0)="NO^1:"_ABPACCNT,DIR("A")="CLAIM ASSIGNMENT" D ^DIR G:'X&(ABPACOD'="P") DIR I 'X D G DIR .W *7,!?5,"<< PENALTYS MUST BE APPLIED - TRANSACTION DELETED >>" .K DIK S DIK="^ABPVAO("_DA(2)_",""P"","_DA(1)_",""A""," D ^DIK G:$D(ABPA("C",X))'=1 DIR S DR="2///"_ABPA("C",X) D ^DIE G DIR DIE3 K DIC,DIE,DA,DR S DA=ABPADDFN,DA(1)=ABPATDFN S DIE="^ABPVAO("_DA(1)_",""P"",",DR="4///N;5///"_DT D ^DIE CONT G ^ABPAPD3 1 S DR="1///S" Q 2 S DR="1///D" Q 3 S DR="1///N" Q 4 S DR="1///P" Q ABPAPD2C ABPAPD2C ; IHS/ADC/CRG - DISPLAY CLAIMS FOR PAYMENT ; [ 04/06/94 9:15 AM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**2**;SEP 17, 1992 A0 S DC=1,D0=ABPATDFN K DXS W @IOF,! D ^ABPAPDA K DXS,ABPA("C") K DIC,DIE,DA,DR,ABPA("QF"),ABPACAMT,ABPACCNT,^TMP($J,"ABPA","HP"),^TMP($J,"ABPA","CP") S ABPADOS=ABPAFRDT-1,(ABPACAMT,ABPACCNT,ABPAOBAL,ABPATPD)=0 S (ABPATA2,ABPATA3,ABPATA4,ABPATA5,ABPATA7)=0 F ABPA("I")=0:0 D Q:$D(ABPA("QF",1))=1 .S ABPADOS=$O(^ABPVAO("PC",ABPATDFN,ABPADOS)) .I +ABPADOS=0!(ABPADOS>ABPATODT) S ABPA("QF",1)="" Q .K ABPA("QF",2) S DA=0 F ABPA("II")=0:0 D Q:$D(ABPA("QF",2))=1 ..S DA=$O(^ABPVAO("PC",ABPATDFN,ABPADOS,DA)) ..I +DA=0 S ABPA("QF",2)="" Q ..Q:$D(^ABPVAO(ABPATDFN,1,DA,0))'=1!($D(ABPACSCR(+DA))=1) ..S ABPAPTR=+DA,ABPADATA=^ABPVAO(ABPATDFN,1,ABPAPTR,0) ..S ^TMP($J,"ABPA","CP",ABPADOS,DA)="0^0^0^0^0^0" ..S ^TMP($J,"ABPA","HP",ABPADOS,DA)=^TMP($J,"ABPA","CP",ABPADOS,DA) ..;------------------------------------------------------------------- ..;BUILD PAYMENT HISTORY ARRAY ..F ABPAJ=2:1:5 S @("ABPAP"_ABPAJ)=0 ..S ABPAZ=0 F ABPAJ=0:0 S ABPAPTOT=0 D Q:+ABPAZ=0 ...S ABPAZ=$O(^ABPVAO("PD",ABPATDFN,DA,ABPAZ)) Q:+ABPAZ=0 ...S ABPAZZ=0 F ABPAK=0:0 D Q:+ABPAZZ=0 ....S ABPAZZ=$O(^ABPVAO(ABPATDFN,"P",ABPAZ,"D",ABPAZZ)) Q:+ABPAZZ=0 ....Q:$D(^ABPVAO(ABPATDFN,"P",ABPAZ,"D",ABPAZZ,0))'=1 S ABPARCD=^(0) ....Q:$P(ABPARCD,"^",2)'=DA F ABPAL=3:1:6 D .....S @("ABPAP"_(ABPAL-1))=@("ABPAP"_(ABPAL-1))+$P(ABPARCD,"^",ABPAL) ..S ABPAPTOT=ABPAP2+ABPAP3+ABPAP4+ABPAP5,ABPATPD=ABPATPD+ABPAPTOT ..S ABPABAL=($P(ABPADATA,"^",7)-ABPAPTOT)-(+$P(ABPADATA,"^",3)) ..S $P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^")=ABPABAL,ABPAOBAL=ABPAOBAL+ABPABAL ..F ABPAJ=2:1:5 S $P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",ABPAJ)=@("ABPAP"_ABPAJ) ..S $P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",6)=ABPAPTOT ..S $P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",7)=+$P(ABPADATA,"^",3) ..;------------------------------------------------------------------- ..S ABPACCNT=ABPACCNT+1,ABPA("C",ABPACCNT)=DA ..W !,ABPACCNT,?2,$J($P(ABPADATA,"^",2),7) ..S ABPA("DTIN")=+ABPADATA D DTCVT^ABPAMAIN W ?10,$J(ABPA("DTOUT"),8) ..W ?19,$J($P(ABPADATA,"^",7),8,2) ..S ABPACAMT=ABPACAMT+$P(ABPADATA,"^",7) ..F I=28,37 S J=$E(I) D ...W ?I,$J($P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",J),8,2) ...S @("ABPATA"_J)=@("ABPATA"_J)+$P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",J) ..W ?46,$J($P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",4),7,2) ..S ABPATA4=ABPATA4+$P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",4) ..W ?54,$J($P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",5),8,2) ..S ABPATA5=ABPATA5+$P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",5) ..W ?63,$J($P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",7),8,2) ..S ABPATA7=ABPATA7+$P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",7) ..W ?72,$J(ABPABAL,8,2) ;K ^TMP($J,"ABPA","HP"),^TMP($J,"ABPA","CP") ;CRGZZ I +ABPACCNT<1 D Q .W !!?5,*7,"<< NO 'ELIGIBLE' CLAIMS FOUND FOR THIS DATE OF SERVICE " .W "PERIOD >>" H 3 I +ABPACCNT>1 W ! D .F ABPAI=19,28,37 W ?(ABPAI),"--------" .W ?46,"-------",?54,"--------",?63,"--------",?72,"--------" .W !?19,$J(ABPACAMT,8,2),?28,$J(ABPATA2,8,2),?37,$J(ABPATA3,8,2) .W ?46,$J(ABPATA4,7,2),?54,$J(ABPATA5,8,2) .W ?63,$J(ABPATA7,8,2),?72,$J(ABPAOBAL,8,2) W !,ABPAXX Q ABPAPD7 ABPAPD7 ; IHS/ADC/CRG - POST PAYMENT EDIT CHECK ; [ 11/17/93 7:54 AM ] STAMP ;;1.5;AO 3P BILLING TRACKING;;SEP 17, 1992 A0 K DIC,DIE,DA,DR,ABPAERR S DA(1)=ABPATDFN,DA=ABPADDFN I +$P(^ABPVAO(DA(1),"P",DA,"A",0),"^",4)'>0 D G A0A^ABPAPD8 .W *7,!!?10,"You have deleted all payment information...therefore," A0A I ((+ABPA("STDAMT")<0)&('ABPA9("GOTCHECK"))) K ABPA("DHS") D .K DIR S DIR(0)="YOA",DIR("A")="Are you issuing a refund (Y/N)? " .S DIR("B")="NO" W *7 D ^DIR I Y D ..K DIR S DIR(0)="FO",DIR("A")="Enter the DHS check number you are " ..S DIR("A")=DIR("A")_"processing" D ^DIR ..I X]""&($E(X)'=" ")&(X'["^") S ABPA("DHS")=X .I $D(ABPA("DHS"))'=1 S ABPAERR="" W *7 D Q ..K ABPAMESS S ABPAMESS="CHECK NUMBER/TRANSACTION TYPE MIS-MATCH" ..D PAUSE^ABPAMAIN .K DIE,DR,DA S DA(1)=ABPATDFN,DA=ABPADDFN,DR=".1///"_ABPA("DHS") .S DIE="^ABPVAO("_ABPATDFN_",""P""," D ^DIE VOID I ((+ABPA("STDAMT")>0)&('ABPA9("GOTCHECK"))) K ABPA("DHS") D .K DIR S DIR(0)="YOA",DIR("A")="Are you voiding a previous refund" .S DIR("A")=DIR("A")_" (Y/N)? ",DIR("B")="NO" W *7 D ^DIR I Y D ..K DIR S DIR(0)="FO",DIR("A")="Enter the DHS check number you are " ..S DIR("A")=DIR("A")_"voiding" D ^DIR ..I X]""&($E(X)'=" ")&(X'["^") S ABPA("DHS")=X .I $D(ABPA("DHS"))'=1 S ABPAERR="" W *7 D Q ..K ABPAMESS S ABPAMESS="CHECK NUMBER/TRANSACTION TYPE MIS-MATCH" ..D PAUSE^ABPAMAIN .K DIE,DR,DA S DA(1)=ABPATDFN,DA=ABPADDFN,DR=".1///"_ABPA("DHS") .S DIE="^ABPVAO("_ABPATDFN_",""P""," D ^DIE I ((+ABPA("STDAMT")=0)&(ABPA9("GOTCHECK"))) S ABPAERR="" W *7 D .K ABPAMESS S ABPAMESS="CHECK NUMBER/TRANSACTION TYPE MIS-MATCH" .D PAUSE^ABPAMAIN I ABPA9("GOTCHECK") I +ABPA("STDAMT")>+ABPACHK("RAMT") S ABPAERR="" W *7 D .K ABPAMESS S ABPAMESS="PAYMENT ALLOCATION-CHECK BALANCE ERROR" .D PAUSE^ABPAMAIN I $D(ABPAERR)=1 K ABPAERR G DISP^ABPAPD3 K ABPA("OPERR"),ABPA("RBERR") D BEGIN^ABPAPD7A,^ABPAPD7C I $D(ABPA("RBERR"))'=0 D K ABPA("RBERR") G A0A^ABPAPD8 .S ABPAMESS="YOU CANNOT REFUND MORE THAN WAS PREVIOUSLY POSTED" W *7 .D PAUSE^ABPAMAIN I $D(ABPA("OPERR"))'=0 D K ABPA("OPERR") G A0A^ABPAPD8 .S ABPAMESS="ILLEGAL OVERPAYMENT ENCOUNTERED" W *7 .D PAUSE^ABPAMAIN K DIR S DIR("A",1)="1 - Execute write-offs, 2 - Select write-offs" S DIR("A",1)=DIR("A",1)_", 3 - Do not write-off, 4 - Cancel" S DIR("A")="Select ACTION: ",DIR(0)="SOA^1:Execute write-offs;" S DIR(0)=DIR(0)_"2:Select write-off;3:Do not write-off;4:Cancel;" S DIR("B")=1 D ^DIR G:+Y=0!(+Y=4) A0A^ABPAPD8 S ABPA("Y")=+Y FILE ;ENTRY POINT ;SET CLAIM SPECIFIC PAYMENT TRANSACTION AMOUNTS ;REQUIRES ABPATDFN=CURRENT PATIENT DFN, ABPADDFN=CURRENT PAYMENT DFN ;REQUIRES THE ARRAY ABPA("PP",ABPADOS,DA) BE DEFINED WHERE: ;ABPADOS=CLAIM DOS, DA=CLAIM DFN ;REQUIRES ABPA("Y")=1, 2, OR 3 WHERE 1=EXECUTE AUTOMATIC WRITE-OFFS, ;2=EXECUTE SELECTIVE WRITE-OFFS, 3=EXECUTE NO WRITE-OFFS ; ; TMD - Added the following line to update the EXPORT STATUS field S DA(1)=ABPATDFN,DIE="^ABPVAO("_DA(1)_","_"""P"""_",",DA=ABPADDFN,DR=".11///A" D ^DIE ; K DIC,DIE,DA,DR,DIK,ABPA("QF"),ABPADOS S ABPAD=0 F ABPA("I")=0:0 D Q:+ABPAD=0 .S ABPAD=$O(^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPAD)) Q:+ABPAD=0 .Q:$D(^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPAD,0))'=1 S ABPADATA=^(0) .S ABPADOS=+ABPADATA,DA=$P(ABPADATA,"^",2) Q:+ABPADOS=0!(+DA<1) .Q:$D(^ABPVAO(ABPATDFN,1,DA,0))'=1!($D(ABPA("PP",ABPADOS,DA))'=1) .F P=2:1:5 S $P(ABPADATA,"^",P+1)=$P(ABPA("CP",ABPADOS,DA),"^",P) .S ^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPAD,0)=ABPADATA K DIE,DR .Q:$D(ABPA("CONVERT"))=1 .I +ABPA("PP",ABPADOS,DA)'>0 D Q ..S DA(1)=ABPATDFN,DIE="^ABPVAO("_DA(1)_",1,",DR=".18///C" D ^DIE .I ABPA("Y")=1 D Q ..S $P(^ABPVAO(ABPATDFN,1,DA,0),"^",3)=+ABPA("PP",ABPADOS,DA) ..S DA(1)=ABPATDFN,DIE="^ABPVAO("_DA(1)_",1,",DR=".18///C" D ^DIE .I ABPA("Y")=2 D Q ..K DIR S DIR(0)="YO",DIR("A")="Write-off the remaining $" ..S DIR("A")=DIR("A")_$J($P(ABPA("PP",ABPADOS,DA),"^"),8,2) ..S DIR("A")=DIR("A")_" for Claim #",DIR("B")="YES" ..S DIR("A")=DIR("A")_$P(^ABPVAO(ABPATDFN,1,DA,0),"^",2) D ^DIR ..I +Y=1 D W "... Written-off!" Q ...S $P(^ABPVAO(ABPATDFN,1,DA,0),"^",3)=+ABPA("PP",ABPADOS,DA) ...S DA(1)=ABPATDFN,DIE="^ABPVAO("_DA(1)_",1,",DR=".18///C" D ^DIE ..W " ... Not written-off!" Q:$D(ABPA("CONVERT"))=1 A3 I ABPA9("GOTCHECK") D .K DIE,DA,DR S DA(2)=$O(ABPACHK("")),DA(1)=$O(ABPACHK(DA(2),"")) .S DA=$O(ABPACHK(DA(2),DA(1),"")) .S DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C""," .S ABPACHK("RAMT")=ABPACHK("RAMT")-ABPA("STDAMT") .S ABPACHK("PAMT")=ABPACHK("AMT")-ABPACHK("RAMT") .S DR="6///P;7///"_ABPACHK("PAMT")_";8///"_ABPACHK("RAMT") .S DR=DR_";9///"_DUZ_";10///NOW" D ^DIE .K DIK S DIK=DIE D IX^DIK L -^ABPVAO(ABPATDFN) K DIC,DIE,DA,DR,ABPACAMT,ABPAPAMT,DIK,ABPADOS,ABPA("I"),ABPA("QF") K ABPAPOST,ABPASDT,ABPARECV,ABPADATA,ABPACHK,CLOSE,ABPA("CHK") G ^ABPAPD1 ABPAPD7A ABPAPD7A ; IHS/ADC/CRG - ALLOCATE APPLIED PAYMENT TRANS. ; [ 04/06/94 9:16 AM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**2**;SEP 17, 1992 D NOENTRY^ABPAMAIN Q BEGIN ;ENTRY POINT ;ALLCOCATE DIRECTLY APPLIED CURRENT TRANSACTIONS S ABPACDFN=0 F ABPAI=0:0 D Q:+ABPACDFN=0 .S ABPACDFN=$O(ABPA("AP",ABPACDFN)) Q:+ABPACDFN=0 .Q:$D(^ABPVAO(ABPATDFN,1,ABPACDFN,0))'=1 S ABPADOS=+^(0) .F ABPAJ=1:1:6 S @("ABPAP"_ABPAJ)=0 .S DA=0 F ABPAJ=0:0 D Q:+DA=0 ..S DA=$O(ABPA("AP",ABPACDFN,DA)) Q:+DA=0 ..I $P(ABPA("AP",ABPACDFN,DA),"^",2)="P" D Q ...S ABPAP2=ABPAP2+(+ABPA("AP",ABPACDFN,DA)) ..I $P(ABPA("AP",ABPACDFN,DA),"^",2)="N" D Q ...S ABPAP3=ABPAP3+(+ABPA("AP",ABPACDFN,DA)) ..I $P(ABPA("AP",ABPACDFN,DA),"^",2)="D" D Q ...S ABPAP4=ABPAP4+(+ABPA("AP",ABPACDFN,DA)) ..I $P(ABPA("AP",ABPACDFN,DA),"^",2)="S" D Q ...S ABPAP5=ABPAP5+(+ABPA("AP",ABPACDFN,DA)) .F ABPAJ=2:1:5 D ..S $P(^TMP($J,"ABPA","CP",ABPADOS,ABPACDFN),"^",ABPAJ)=@("ABPAP"_ABPAJ) .S ABPACPD=0 F ABPAJ=2:1:5 S ABPACPD=@("ABPAP"_ABPAJ)+ABPACPD .S $P(^TMP($J,"ABPA","CP",ABPADOS,ABPACDFN),"^",6)=ABPACPD ;--------------------------------------------------------------------- ;THIS PROCEDURE WILL ALLOCATE ANY PAYMENT TRANSACTION NOT DIRECTLY ;LINKED TO A SPECIFIC BILL ACCROSS ALL BILLS INVOLVED IN THE TRANS- ;ACTION ACCORDING TO THE PROPORTIONAL VALUE OF EACH BILL'S OUT- ;STANDING BALANCE AT THE TIME OF ALLOCATION. ;DEDUCTIBLE TRANSACTIONS ARE DEDUCTED FROM THE OLDEST BILL OR BILLS ;UNTIL THE ENTIRE TRANSACTION HAS BEEN ALLOCATED PRIOR TO ANY OTHER ;TRANSACTIONS BEING PROPROTIONATELY ALLOCATED. S (ABPA("PB"),ABPA("NB"),ABPA("DB"),ABPA("SB"),ABPACTOB,ABPADOS)=0 F ABPAI=0:0 D Q:+ABPADOS=0 .S ABPADOS=$O(^TMP($J,"ABPA","HP",ABPADOS)) Q:+ABPADOS=0 .S DA=0 F ABPAJ=0:0 D Q:+DA=0 ..S DA=$O(^TMP($J,"ABPA","HP",ABPADOS,DA)) Q:+DA=0 ..F ABPAK=1:1:6 D ...S @("ABPAP"_ABPAK)=$P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",ABPAK) ...S @("ABPAT"_ABPAK)=$P(^TMP($J,"ABPA","CP",ABPADOS,DA),"^",ABPAK) ..S ABPAZ=0 F ABPAX=2:1:5 D ...S ABPAY=@("ABPAP"_ABPAX)+@("ABPAT"_ABPAX),ABPAZ=ABPAZ+ABPAY ...S $P(ABPA("PP",ABPADOS,DA),"^",ABPAX)=ABPAY ..S $P(ABPA("PP",ABPADOS,DA),"^",6)=ABPAZ ..S $P(ABPA("PP",ABPADOS,DA),"^")=ABPAP1-ABPAT6 ..S ABPACTOB=ABPACTOB+(ABPAP1-ABPAT6) ..S ABPA("PB")=ABPA("PB")+$P(ABPA("PP",ABPADOS,DA),"^",2) ..S ABPA("NB")=ABPA("NB")+$P(ABPA("PP",ABPADOS,DA),"^",3) ..S ABPA("DB")=ABPA("DB")+$P(ABPA("PP",ABPADOS,DA),"^",4) ..S ABPA("SB")=ABPA("SB")+$P(ABPA("PP",ABPADOS,DA),"^",5) I +ABPA("UP","N")<0 D NONCOV^ABPAPD7D I +ABPA("UP","D")<0 D DEDUCT^ABPAPD7D I +ABPA("UP","S")<0 D PAID^ABPAPD7D G BEGIN^ABPAPD7B ABPAPD7C ABPAPD7C ; IHS/ADC/CRG - DISPLAY CLAIMS AFTER TRANS ALLOCATION ; [ 04/06/94 9:17 AM ] STAMP ;;1.5;AO 3P BILLING TRACKING;**2**;SEP 17, 1992 A0 S DC=1,D0=ABPATDFN K DXS W @IOF,! D ^ABPAPDA K DXS K DIC,DIE,DA,DR,ABPACAMT,ABPACCNT S ABPADOS=ABPAFRDT-1,(ABPACAMT,ABPACCNT,ABPACTPD)=0 S (ABPATA2,ABPATA3,ABPATA4,ABPATA5,ABPATA5)=0 LOOP F D Q:'ABPADOS .S ABPADOS=$O(^ABPVAO("PC",ABPATDFN,ABPADOS)) .Q:+ABPADOS=0!(ABPADOS>ABPATODT) S DA=0 F D Q:'DA ..S DA=$O(^ABPVAO("PC",ABPATDFN,ABPADOS,DA)) Q:'DA ..Q:$D(^ABPVAO(ABPATDFN,1,DA,0))'=1!($D(ABPACSCR(+DA))=1) ..S ABPAPTR=+DA,ABPADATA=^ABPVAO(ABPATDFN,1,ABPAPTR,0) ..S ABPACCNT=ABPACCNT+1 W !,ABPACCNT,?2,$J($P(ABPADATA,"^",2),7) ..S ABPA("DTIN")=+ABPADATA D DTCVT^ABPAMAIN W ?10,$J(ABPA("DTOUT"),8) ..W ?19,$J($P(ABPADATA,"^",7),8,2) ..S ABPACAMT=ABPACAMT+$P(ABPADATA,"^",7) F I=28,37 S J=$E(I) D ...W ?I,$J($P(ABPA("PP",ABPADOS,DA),"^",J),8,2) ...S @("ABPATA"_J)=@("ABPATA"_J)+$P(ABPA("PP",ABPADOS,DA),"^",J) ...S:+$P(ABPA("PP",ABPADOS,DA),"^",J)<0 ABPA("OPERR")="" ..W ?46,$J($P(ABPA("PP",ABPADOS,DA),"^",4),7,2) ..S ABPATA4=ABPATA4+$P(ABPA("PP",ABPADOS,DA),"^",4) ..S:+$P(ABPA("PP",ABPADOS,DA),"^",4)<0 ABPA("OPERR")="" ..W ?54,$J($P(ABPA("PP",ABPADOS,DA),"^",5),8,2) ..S ABPATA5=ABPATA5+$P(ABPA("PP",ABPADOS,DA),"^",5) ..S:+$P(ABPA("PP",ABPADOS,DA),"^",5)<0 ABPA("OPERR")="" ..W ?63,$J($P(ABPA("PP",ABPADOS,DA),"^",7),8,2) ..S ABPATA7=ABPATA7+$P(ABPA("PP",ABPADOS,DA),"^",7) ..S ABPACTPD=ABPACTPD+$P(ABPA("PP",ABPADOS,DA),"^",6) ..W ?72,$J(+ABPA("PP",ABPADOS,DA),8,2) ..I +ABPA("PP",ABPADOS,DA)<0&(+$P(ABPA("PP",ABPADOS,DA),"^",5)'>0) D ...S ABPA("OPERR")="" ..I +ABPA("PP",ABPADOS,DA)>+$P(ABPADATA,"^",7) S ABPA("OPERR")="" I +ABPACCNT>1 W ! D .F ABPAI=19,28,37 W ?ABPAI,"--------" .W ?46,"-------" F ABPAI=54,63,72 W ?ABPAI,"--------" .W !?19,$J(ABPACAMT,8,2),?28,$J(ABPATA2,8,2),?37,$J(ABPATA3,8,2) .W ?46,$J(ABPATA4,7,2),?54,$J(ABPATA5,8,2) .W ?63,$J(ABPATA7,8,2),?72,$J(ABPACTOB,8,2) W !,ABPAXX CURARAY ;ENTRY POINT ;BUILD A COMPOSITE ARRAY OF CURRENT TRANS. AS ALLOCATED S ABPADOS=0 F ABPAI=0:0 D Q:+ABPADOS=0 .S ABPADOS=$O(^TMP($J,"ABPA","HP",ABPADOS)) Q:+ABPADOS=0 .S DA=0 F ABPAJ=0:0 D Q:+DA=0 ..S DA=$O(^TMP($J,"ABPA","HP",ABPADOS,DA)) Q:+DA=0 ..F ABPAK=2:1:5 D ...S @("ABPAH"_ABPAK)=$P(^TMP($J,"ABPA","HP",ABPADOS,DA),"^",ABPAK) ...S @("ABPAP"_ABPAK)=$P(ABPA("PP",ABPADOS,DA),"^",ABPAK) ...S ABPACURA=@("ABPAP"_ABPAK)-@("ABPAH"_ABPAK) ...S $P(^TMP($J,"ABPA","CP",ABPADOS,DA),"^",ABPAK)=ABPACURA Q ABPDTCV ABPDTCV ; IHS/ADC/CRG - DATE CONVERSION UTILITY ; [ 01/17/96 3:24 PM ] ;;1.5;AO 3P BILLING TRACKING;**6**;JAN 10, 1996 ; EP(ABPDATE) ;Date conversion from fileman to mm/dd/yy Q $E(ABPDATE,4,5)_"/"_$E(ABPDATE,6,7)_"/"_$E(ABPDATE,2,3)