ABMDPAY1 ; IHS/ASDST/DMJ - Payment of Bill - Part 2 ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;
; IHS/ASDS/SDH - 08/14/01 - V2.4 Patch 9 - NOIS NDA-1199-180065
; Modified to accept negative numbers and take out range
;
; *********************************************************************
;
V ;EP for Viewing Payments
G ^ABMDPAYV
;
D ;EP for Deleting a Payment
I +$E(Y,2,3)>0&(+$E(Y,2,3)<(ABM("I")+1)) S Y=+$E(Y,2,3) G D2
I ABM("I")=1 S Y=1 G D2
K DIR S DIR(0)="NO^1:"_ABM("I")_":0"
S DIR("?")="Enter the Sequence Number of the PAYMENT to DELETE",DIR("A")="Sequence Number to DELETE"
D ^DIR K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(Y'>0)
D2 W ! S ABM("ANS")=+Y K DIR S DIR(0)="YO",DIR("A")="Do you wish PAYMENT Number "_ABM("ANS")_" DELETED" D ^DIR K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
D3 I Y=1 S DA(1)=ABMP("BDFN"),DA=ABM("I",ABM("ANS")),DIK="^ABMDBILL(DUZ(2),"_DA(1)_",3," D ^DIK
Q
;
A ;EP for Adding a Payment
K DIR S DIR(0)="DAO^"_ABMP("VDT")_":"_DT,DIR("A")="Enter NEW PAYMENT Date: " D ^DIR
K DIR Q:$D(DIRUT)!$D(DIROUT)
;
ADT ;EP for Adding Payment with known Payment Date (Y)
I '$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),3,0)) S ^ABMDBILL(DUZ(2),ABMP("BDFN"),3,0)="^9002274.403D^^"
S ABM("PDT")=+Y,X=+Y
K DIC,DD,DO,DINUM
S DA(1)=ABMP("BDFN"),DIC="^ABMDBILL(DUZ(2),"_DA(1)_",3,",DIC(0)="LE"
D FILE^DICN K DIC
Q:+Y<1!$D(DTOUT)!$D(DUOUT) S ABM("PAYM")=+Y
I $P(Y,U,3)=1,"ABT"[$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U,4) S DIE="^ABMDBILL(DUZ(2),",DA=ABMP("BDFN"),DR=".04////P" D ^DIE
G EDIT
;
E ;EP for Editing a Payment
I ABM("I")=0 W *7,!!,"There are no entries to edit, you must first ADD an entry.",! K DIR S DIR(0)="E" D ^DIR K DIR Q
I $E(Y,2)>0&($E(Y,2)<(ABM("I")+1)) S Y=$E(Y,2) G E2
I ABM("I")=1 S Y=1 G E2
K DIR S DIR(0)="NO^1:"_ABM("I")_":0"
S DIR("?")="Enter the Sequence Number of the PAYMENT to Edit",DIR("A")="Sequence Number to EDIT"
D ^DIR K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(+Y'>0)
E2 S ABM("PAYM")=+Y W !!,"[",+Y,"] ",$$HDT^ABMDUTL($P(ABM(+Y),U)),!,"==================="
S ABM("PAYM")=ABM("I",ABM("PAYM"))
;
; var def: ABM(TOT) = paid amt ^ deductible amt ^ write-off amt
;
EDIT S ABM("P0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),3,ABM("PAYM"),0)
S ABM("OB")=ABM("OB")+$P(ABM("P0"),U,2)+$P(ABM("P0"),U,3)+$P(ABM("P0"),U,4)
S $P(ABM("TOT"),U)=$P(ABM("TOT"),U)-$P(ABM("P0"),U,2)
S $P(ABM("TOT"),U,2)=$P(ABM("TOT"),U,2)-$P(ABM("P0"),U,3)-$P(ABM("P0"),U,4)
S DA(1)=ABMP("BDFN"),DIE="^ABMDBILL(DUZ(2),"_DA(1)_",3,",DA=ABM("PAYM"),DR=".02R~Payment Amount.....: ;.03Deductible Amount..: ;S:X Y=""@1"";.04Co-Insurance Amount: ;@1" D ^DIE K DR Q:$D(Y)
S ABM("P0")=^ABMDBILL(DUZ(2),DA(1),3,DA,0)
S $P(ABM("TOT"),U)=$P(ABM("TOT"),U)+$P(ABM("P0"),U,2)
S $P(ABM("TOT"),U,2)=$P(ABM("TOT"),U,2)+$P(ABM("P0"),U,3)+$P(ABM("P0"),U,4)
S ABM("OB")=ABM("OB")-$P(ABM("P0"),U,2)-$P(ABM("P0"),U,3)-$P(ABM("P0"),U,4)
I $P(ABM("P0"),U,6)<0,ABM("OB") D
.S $P(ABM("P0"),U,6)=ABM("OB")+$P(ABM("P0"),U,6),ABM("OB")=0
.S DA(1)=ABMP("BDFN"),DIE="^ABMDBILL(DUZ(2),"_DA(1)_",3,",DA=ABM("PAYM")
.S DR=".06////"_$P(ABM("P0"),U,6) D ^DIE
I ABM("OB")<0,$P($G(^AUTNINS(ABMP("INS"),2)),U,2)="Y" D G E3
.S DA(1)=ABMP("BDFN"),DIE="^ABMDBILL(DUZ(2),"_DA(1)_",3,",DA=ABM("PAYM")
.S DR=".06////"_($P(^ABMDBILL(DUZ(2),DA(1),3,DA,0),U,6)+ABM("OB")) D ^DIE
.S ABM("OB")=0
W !!?16,"(Unobligated Balance: ",$FN(ABM("OB"),",",2),")",!
I ABM("OB")<1,'$P(ABM("P0"),U,6) G E3
G E3:$P(ABM("P0"),U,6)<0
K DIR S (ABM("WO"),DIR("B"))=$P(ABM("P0"),U,6)
S ABM("WW")=ABM("OB")+ABM("WO") S:ABM("WW")<ABM("WO") ABM("WW")=ABM("WO")
S ABM="-99999:99999:3"
K:DIR("B")="" DIR("B")
S DIR(0)="NOA^"_ABM
S:ABM("WW")<50 DIR("B")=ABM("WW")
S DIR("A")="Write-off Amount: " D ^DIR
S ABM("OB")=ABM("OB")+ABM("WO")-Y,$P(ABM("TOT"),U,3)=+Y
S DA(1)=ABMP("BDFN"),DIE="^ABMDBILL(DUZ(2),"_DA(1)_",3,",DA=ABM("PAYM"),DR=".06////"_+Y D ^DIE
;
E3 S DIE="^ABMDBILL(DUZ(2),",DA=ABMP("BDFN"),DR=".25////"_ABM("OB") D ^DIE
Q:$D(ABMP("PRE-PAY"))
G CHK^ABMDPAY2
ABMDPAY1 ; IHS/ASDST/DMJ - Payment of Bill - Part 2 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;
+3 ; IHS/ASDS/SDH - 08/14/01 - V2.4 Patch 9 - NOIS NDA-1199-180065
+4 ; Modified to accept negative numbers and take out range
+5 ;
+6 ; *********************************************************************
+7 ;
V ;EP for Viewing Payments
+1 GOTO ^ABMDPAYV
+2 ;
D ;EP for Deleting a Payment
+1 IF +$EXTRACT(Y,2,3)>0&(+$EXTRACT(Y,2,3)<(ABM("I")+1))
SET Y=+$EXTRACT(Y,2,3)
GOTO D2
+2 IF ABM("I")=1
SET Y=1
GOTO D2
+3 KILL DIR
SET DIR(0)="NO^1:"_ABM("I")_":0"
+4 SET DIR("?")="Enter the Sequence Number of the PAYMENT to DELETE"
SET DIR("A")="Sequence Number to DELETE"
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(Y'>0)
QUIT
D2 WRITE !
SET ABM("ANS")=+Y
KILL DIR
SET DIR(0)="YO"
SET DIR("A")="Do you wish PAYMENT Number "_ABM("ANS")_" DELETED"
DO ^DIR
KILL DIR
+1 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
D3 IF Y=1
SET DA(1)=ABMP("BDFN")
SET DA=ABM("I",ABM("ANS"))
SET DIK="^ABMDBILL(DUZ(2),"_DA(1)_",3,"
DO ^DIK
+1 QUIT
+2 ;
A ;EP for Adding a Payment
+1 KILL DIR
SET DIR(0)="DAO^"_ABMP("VDT")_":"_DT
SET DIR("A")="Enter NEW PAYMENT Date: "
DO ^DIR
+2 KILL DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+3 ;
ADT ;EP for Adding Payment with known Payment Date (Y)
+1 IF '$DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),3,0))
SET ^ABMDBILL(DUZ(2),ABMP("BDFN"),3,0)="^9002274.403D^^"
+2 SET ABM("PDT")=+Y
SET X=+Y
+3 KILL DIC,DD,DO,DINUM
+4 SET DA(1)=ABMP("BDFN")
SET DIC="^ABMDBILL(DUZ(2),"_DA(1)_",3,"
SET DIC(0)="LE"
+5 DO FILE^DICN
KILL DIC
+6 IF +Y<1!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
SET ABM("PAYM")=+Y
+7 IF $PIECE(Y,U,3)=1
IF "ABT"[$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U,4)
SET DIE="^ABMDBILL(DUZ(2),"
SET DA=ABMP("BDFN")
SET DR=".04////P"
DO ^DIE
+8 GOTO EDIT
+9 ;
E ;EP for Editing a Payment
+1 IF ABM("I")=0
WRITE *7,!!,"There are no entries to edit, you must first ADD an entry.",!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+2 IF $EXTRACT(Y,2)>0&($EXTRACT(Y,2)<(ABM("I")+1))
SET Y=$EXTRACT(Y,2)
GOTO E2
+3 IF ABM("I")=1
SET Y=1
GOTO E2
+4 KILL DIR
SET DIR(0)="NO^1:"_ABM("I")_":0"
+5 SET DIR("?")="Enter the Sequence Number of the PAYMENT to Edit"
SET DIR("A")="Sequence Number to EDIT"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(+Y'>0)
QUIT
E2 SET ABM("PAYM")=+Y
WRITE !!,"[",+Y,"] ",$$HDT^ABMDUTL($PIECE(ABM(+Y),U)),!,"==================="
+1 SET ABM("PAYM")=ABM("I",ABM("PAYM"))
+2 ;
+3 ; var def: ABM(TOT) = paid amt ^ deductible amt ^ write-off amt
+4 ;
EDIT SET ABM("P0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),3,ABM("PAYM"),0)
+1 SET ABM("OB")=ABM("OB")+$PIECE(ABM("P0"),U,2)+$PIECE(ABM("P0"),U,3)+$PIECE(ABM("P0"),U,4)
+2 SET $PIECE(ABM("TOT"),U)=$PIECE(ABM("TOT"),U)-$PIECE(ABM("P0"),U,2)
+3 SET $PIECE(ABM("TOT"),U,2)=$PIECE(ABM("TOT"),U,2)-$PIECE(ABM("P0"),U,3)-$PIECE(ABM("P0"),U,4)
+4 SET DA(1)=ABMP("BDFN")
SET DIE="^ABMDBILL(DUZ(2),"_DA(1)_",3,"
SET DA=ABM("PAYM")
SET DR=".02R~Payment Amount.....: ;.03Deductible Amount..: ;S:X Y=""@1"";.04Co-Insurance Amount: ;@1"
DO ^DIE
KILL DR
IF $DATA(Y)
QUIT
+5 SET ABM("P0")=^ABMDBILL(DUZ(2),DA(1),3,DA,0)
+6 SET $PIECE(ABM("TOT"),U)=$PIECE(ABM("TOT"),U)+$PIECE(ABM("P0"),U,2)
+7 SET $PIECE(ABM("TOT"),U,2)=$PIECE(ABM("TOT"),U,2)+$PIECE(ABM("P0"),U,3)+$PIECE(ABM("P0"),U,4)
+8 SET ABM("OB")=ABM("OB")-$PIECE(ABM("P0"),U,2)-$PIECE(ABM("P0"),U,3)-$PIECE(ABM("P0"),U,4)
+9 IF $PIECE(ABM("P0"),U,6)<0
IF ABM("OB")
Begin DoDot:1
+10 SET $PIECE(ABM("P0"),U,6)=ABM("OB")+$PIECE(ABM("P0"),U,6)
SET ABM("OB")=0
+11 SET DA(1)=ABMP("BDFN")
SET DIE="^ABMDBILL(DUZ(2),"_DA(1)_",3,"
SET DA=ABM("PAYM")
+12 SET DR=".06////"_$PIECE(ABM("P0"),U,6)
DO ^DIE
End DoDot:1
+13 IF ABM("OB")<0
IF $PIECE($GET(^AUTNINS(ABMP("INS"),2)),U,2)="Y"
Begin DoDot:1
+14 SET DA(1)=ABMP("BDFN")
SET DIE="^ABMDBILL(DUZ(2),"_DA(1)_",3,"
SET DA=ABM("PAYM")
+15 SET DR=".06////"_($PIECE(^ABMDBILL(DUZ(2),DA(1),3,DA,0),U,6)+ABM("OB"))
DO ^DIE
+16 SET ABM("OB")=0
End DoDot:1
GOTO E3
+17 WRITE !!?16,"(Unobligated Balance: ",$FNUMBER(ABM("OB"),",",2),")",!
+18 IF ABM("OB")<1
IF '$PIECE(ABM("P0"),U,6)
GOTO E3
+19 IF $PIECE(ABM("P0"),U,6)<0
GOTO E3
+20 KILL DIR
SET (ABM("WO"),DIR("B"))=$PIECE(ABM("P0"),U,6)
+21 SET ABM("WW")=ABM("OB")+ABM("WO")
IF ABM("WW")<ABM("WO")
SET ABM("WW")=ABM("WO")
+22 SET ABM="-99999:99999:3"
+23 IF DIR("B")=""
KILL DIR("B")
+24 SET DIR(0)="NOA^"_ABM
+25 IF ABM("WW")<50
SET DIR("B")=ABM("WW")
+26 SET DIR("A")="Write-off Amount: "
DO ^DIR
+27 SET ABM("OB")=ABM("OB")+ABM("WO")-Y
SET $PIECE(ABM("TOT"),U,3)=+Y
+28 SET DA(1)=ABMP("BDFN")
SET DIE="^ABMDBILL(DUZ(2),"_DA(1)_",3,"
SET DA=ABM("PAYM")
SET DR=".06////"_+Y
DO ^DIE
+29 ;
E3 SET DIE="^ABMDBILL(DUZ(2),"
SET DA=ABMP("BDFN")
SET DR=".25////"_ABM("OB")
DO ^DIE
+1 IF $DATA(ABMP("PRE-PAY"))
QUIT
+2 GOTO CHK^ABMDPAY2
