ABMPPAD2 ; IHS/SD/SDR - Prior Payments/Adjustments page (CE);
;;2.6;IHS 3P BILLING SYSTEM;**11**;NOV 12, 2009;Build 133
;
DISP ;EP
K ABMSFLG,ABMMFLG,ABMEFLG,ABMRSTR
D SETVAR^ABMPPAD1
S ABMDASH="",$P(ABMDASH,"-",80)=""
S ABMZ("TITL")="PRIOR PAYMENTS/ADJUSTMENTS"
S ABMP("SCRN")="A"
S ABMZ("PG")="A"
I '$D(ABMP("DDL")) D SUM^ABMDE1 I 1
E S ABMC("CONT")="" D PAUSE^ABMDE1 G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) XIT
;
S ABMINS=0
F S ABMINS=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS)) Q:+ABMINS=0 D
.S ABMIIEN=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U)
.S ABMPRI=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U,2)
.S ABMSTAT=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U,3)
.Q:ABMSTAT'="I"&(ABMSTAT'="C")
.S ABMLST("PRIO",ABMPRI,ABMIIEN)=ABMINS_"^"_ABMSTAT
;
S ABMP("CBAMT")=0
S ABMIPRI=0
F S ABMIPRI=$O(ABMLST("PRIO",ABMIPRI)) Q:+ABMIPRI=0 D
.S ABMIIEN=0
.F S ABMIIEN=$O(ABMLST("PRIO",ABMIPRI,ABMIIEN)) Q:+ABMIIEN=0 D
..S ABMCAT=""
..F S ABMCAT=$O(ABMLST("TRANS",ABMIIEN,ABMCAT)) Q:ABMCAT="" D
...S ABMLN=0
...F S ABMLN=$O(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN)) Q:+ABMLN=0 D
....S ABMTREC=$G(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN))
....I $P(ABMTREC,U,5)="Y" S ABMP("CBAMT")=ABMP("CBAMT")+($FN($P(ABMTREC,U),"-"))
....I ABMCAT="P" S ABMPM("PD")=+$G(ABMPM("PD"))+($P(ABMTREC,U))
....I ABMCAT="A" D
.....S ABMATYP=$P(ABMTREC,U,2)
.....S ABMAAMT=$P(ABMTREC,U)
.....S:ABMATYP=3 ABMPM("WO")=+$G(ABMPM("WO"))+ABMAAMT
.....S:ABMATYP=4 ABMPM("NONC")=+$G(ABMPM("NONC"))+ABMAAMT
.....S:ABMATYP=13 ABMPM("DED")=+$G(ABMPM("DED"))+ABMAAMT
.....S:ABMATYP=14 ABMPM("COI")=+$G(ABMPM("COI"))+ABMAAMT
.....S:ABMATYP=15 ABMPM("PENS")=+$G(ABMPM("PENS"))+ABMAAMT
.....S:ABMATYP=16 ABMPM("GRP")=+$G(ABMPM("GRP"))+ABMAAMT
.....S:ABMATYP=19 ABMPM("REF")=+$G(ABMPM("REF"))+ABMAAMT
.....S:ABMATYP=20 ABMPM("PCR")=+$G(ABMPM("PCR"))+ABMAAMT
;
W !,"Payment Amount....: " S ABMNFLG=1 W $$DOLAMT(ABMPM("PD")) K ABMNFLG
W ?40,"Deductible Amount.: ",$$DOLAMT(ABMPM("DED"))
W !,"Payment Credits...: ",$$DOLAMT(ABMPM("PCR"))
W ?40,"Co-pay/ins Amount.: ",$$DOLAMT(ABMPM("COI"))
W !?40,"Write Off.........: ",$$DOLAMT(ABMPM("WO"))
W !,"Refund............: ",$$DOLAMT(ABMPM("REF"))
W ?40,"Non-Covered Amount: ",$$DOLAMT(ABMPM("NONC"))
W !?40,"Penalty Amount....: ",$$DOLAMT(ABMPM("PENS"))
W !?40,"Grouper Allowance.: ",$$DOLAMT(ABMPM("GRP"))
S ABMRVFLG=1 ;abm*2.6*11 HEAT81390
;
S ABMPRI=0
F S ABMPRI=$O(ABMLST("PRIO",ABMPRI)) Q:+ABMPRI=0 D
.S ABMIIEN=0
.S ABMPRIS=ABMPRI
.F S ABMIIEN=$O(ABMLST("PRIO",ABMPRI,ABMIIEN)) Q:+ABMIIEN=0 D
..S ABMSTAT=$P(ABMLST("PRIO",ABMPRI,ABMIIEN),U,2)
..S ABMINS=$P(ABMLST("PRIO",ABMPRI,ABMIIEN),U)
..S ABMSTAT=$S(ABMSTAT="F":"FLAGGED",ABMSTAT="I":"ACTIVE",ABMSTAT="P":"PENDING",ABMSTAT="U":"UNBILLABLE",ABMSTAT="C":"COMPLETED",ABMSTAT="B":"BILLED",ABMSTAT="L":"PARTIAL",1:"")
..W !!,"["_ABMPRI_"] INSURER: ",$E($P($G(^AUTNINS(ABMIIEN,0)),U),1,27)
..W ?40,"PRIORITY ORDER: ",ABMPRI
..W ?62,"STATUS: "
..W $S(ABMSTAT="COMPLETED":$$EN^ABMVDF("RVN"),1:""),ABMSTAT,$S(ABMSTAT="COMPLETED":$$EN^ABMVDF("RVF"),1:"")
..S ABMCOV=0
..F S ABMCOV=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,11,ABMCOV)) Q:+ABMCOV=0 D
...I $P($G(^AUTNINS(ABMIIEN,0)),U)["MEDICARE" D
....W !?14,"COVERAGE TYPE: ",$P($G(^AUTTPIC(ABMCOV,0)),U)
....S ABMCOV=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,11,ABMCOV))
....I +ABMCOV'=0 W ", ",$P($G(^AUTTPIC(ABMCOV,0)),U)
...E W !?14,"COVERAGE TYPE: ",$P($G(^AUTTPIC(ABMCOV,0)),U)
..S ABMCAT=""
..F S ABMCAT=$O(ABMLST("TRANS",ABMIIEN,ABMCAT),-1) Q:ABMCAT="" D
...S ABMLN=0
...F S ABMLN=$O(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN)) Q:+ABMLN=0 D
....Q:+$P(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN),U)=0
....I +$G(ABMLNSV)<ABMLN S ABMLNSV=ABMLN
....S ABMDAMT=$P($G(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN)),U)
....I ABMCAT="P" S ABMNFLG=1
....S ABMDAMT=$$DOLAMT(ABMDAMT)
....K ABMNFLG
....I ABMCAT="P" W !?6,"PYMT: ",ABMDAMT
....E D ADJS
W !,ABMDASH,!
I ("^21^22^23^31^32^33^"[("^"_ABMP("EXP")_"^")) D
.I $G(ABMSFLG)=1 W "ERROR: STANDARD ADJUSTMENT CODE NOT ENTERED FOR ADJUSTMENT",!
.I $G(ABMMFLG)=1 W "ERROR: STANDARD ADJUSTMENT REASON DOESN'T MATCH ADJUSTMENT CATEGORY/REASON",!
.I ABMP("CBAMT")<0 W "ERROR: NEGATIVE BALANCE ON BILL NOT ALLOWED",! S ABMSFLG=1
.I $G(ABMSFLG)=1!($G(ABMMFLG)=1) W ABMDASH,!
.I $G(ABMSFLG)=1 W "**Use the EDIT option to populate the Standard Adjustment Reason Code**",!
E K ABMSFLG,ABMMFLG ;remove flag for other checks of this error
;
S ABMP("OPT")="AERSQ"
S ABMP("DFLT")="Q"
D SEL
I "AERS"'[$E(Y) D XIT^ABMPPADJ Q
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) D XIT^ABMPPADJ Q
S ABM("DO")=$S($E(Y)="A":"ADD^ABMPPADJ",$E(Y)="E":"EDIT^ABMPPADJ",$E(Y)="R":"RESTR^ABMPPADJ",$E(Y)="S":"EN^ABMPPFLR",1:"XIT^ABMPPADJ") D @ABM("DO")
G DISP
Q
ADJS ;EP
W !?7,"ADJ: ",ABMDAMT
S ABMPREC=$G(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN))
;I $P(ABMPREC,U,5)="Y" W ?24,"<B>"
;I $P(ABMPREC,U,5)="N" W ?24,"<N>"
I $P(ABMPREC,U,2)'="" W ?28,"[",$P(ABMPREC,U,2),"] ",$E($P($G(^BAR(90052.01,$P(ABMPREC,U,2),0)),U),1,18)
I $P(ABMPREC,U,3)'="" W ?47,"[",$P(ABMPREC,U,3),"] ",$E($P($G(^BARTBL($P(ABMPREC,U,3),0)),U),1,18)
I $P($G(ABMPREC),U,4)'="" D
.W ?75,"["_$P(^BARADJ($P($G(ABMPREC),U,4),0),U)_"]"
.I $P(^BARADJ($P(ABMPREC,U,4),0),U,3)'=$P(ABMPREC,U,2) S ABMMFLG=1
.I $P(^BARADJ($P(ABMPREC,U,4),0),U,4)'=$P(ABMPREC,U,3) S ABMMFLG=1
I $P($G(ABMPREC),U,4)="",($P(ABMPREC,U)'=0) S ABMSFLG=1
Q
DOLAMT(AMT) ;
Q $S(($E(AMT,1)="-"!($G(ABMNFLG)=1))&(AMT'=0):"("_$J($S($E(AMT)="-":$E(AMT,2,$L(AMT)),1:AMT),10,2)_")",1:$J(+$G(AMT),11,2))
;
SEL ;EP for Page Commands, Desired Action Controller
I $D(ABMP("DDL")),$D(ABMP("QUIT")) S Y="Q" G XIT
S:'$D(ABMP("DFLT")) ABMP("DFLT")=""
K %P,DIR S DIR(0)="F^1:9"
S (DIR("B"),ABMO("DFLT"))=$S(ABMP("DFLT")]"":ABMP("DFLT"),ABMP("OPT")'["N":"B",1:"N")
S DIR("A")="Desired ACTION ("
S DIR("?",1)=" Choose from one of the following actions:"
S DIR("?",2)=" "
F ABMO("CTR")=3:1 S ABMO("TXT")=$E(ABMP("OPT"),ABMO("CTR")-2) Q:ABMO("TXT")="" D
.I $D(ABMP("VIEWMODE")),"NVBJQ"'[ABMO("TXT") Q
.S DIR("?",ABMO("CTR"))=$P($T(@ABMO("TXT")),";;",2),DIR("A")=DIR("A")_$P($T(@ABMO("TXT")),";;",3)_"/"
S DIR("?",ABMO("CTR"))=" "
S DIR("?")=" Enter First Character of the Desired Action."
S DIR("A")=$P(DIR("A"),"/",1,$L(DIR("A"),"/")-1)_")"
D ^DIR K DIR
G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
S:X="" Y=ABMO("DFLT")
S Y=$$UPC^ABMERUTL(Y)
I $E(X)="?" D ^ABMDEHLP G SEL
I '+$E(Y),'+$E(Y,2),$E(Y,2)'=0 S Y=$E(Y)
I $A(Y,1)>96&($A(Y,1)<123) S Y=$C($A(Y,1)-32)_$E(Y,2,99)
I ABMP("OPT")[$E(Y) K ABMP("DFLT") G XIT
I +Y,$D(ABMZ("NUM")),Y<(ABMZ("NUM")+1) K ABMP("DFLT") S Y="E"_+Y G XIT
W *7 G SEL
;
A ;; Add - Add a New Entry;;Add
E ;; Edit - Edit Information in the Current Screen;;Edit
R ;; Rstr - Restore transactions from A/R;;Restore
S ;; Save - Save transactions;;Save
Q ;; Quit - Stop Editing the Data;;Quit
;
FLDS ;EP for Field Edit Controller
S ABMO("Y")=+$E(Y,2,3) I ABMO("Y")>0&(ABMO("Y")<(ABMP("FLDS")+1)) S Y=ABMO("Y") G EJ
W ! S DIR(0)="LO^1:"_ABMP("FLDS"),DIR("A")="Desired FIELDS",DIR("B")="1-"_ABMP("FLDS") D ^DIR K DIR
G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
EJ S ABMP("FLDS")=Y
G XIT
;
XIT K ABMO,ABMP("OPT")
Q
ABMPPAD2 ; IHS/SD/SDR - Prior Payments/Adjustments page (CE);
+1 ;;2.6;IHS 3P BILLING SYSTEM;**11**;NOV 12, 2009;Build 133
+2 ;
DISP ;EP
+1 KILL ABMSFLG,ABMMFLG,ABMEFLG,ABMRSTR
+2 DO SETVAR^ABMPPAD1
+3 SET ABMDASH=""
SET $PIECE(ABMDASH,"-",80)=""
+4 SET ABMZ("TITL")="PRIOR PAYMENTS/ADJUSTMENTS"
+5 SET ABMP("SCRN")="A"
+6 SET ABMZ("PG")="A"
+7 IF '$DATA(ABMP("DDL"))
DO SUM^ABMDE1
IF 1
+8 IF '$TEST
SET ABMC("CONT")=""
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
+9 ;
+10 SET ABMINS=0
+11 FOR
SET ABMINS=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS))
IF +ABMINS=0
QUIT
Begin DoDot:1
+12 SET ABMIIEN=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U)
+13 SET ABMPRI=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U,2)
+14 SET ABMSTAT=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U,3)
+15 IF ABMSTAT'="I"&(ABMSTAT'="C")
QUIT
+16 SET ABMLST("PRIO",ABMPRI,ABMIIEN)=ABMINS_"^"_ABMSTAT
End DoDot:1
+17 ;
+18 SET ABMP("CBAMT")=0
+19 SET ABMIPRI=0
+20 FOR
SET ABMIPRI=$ORDER(ABMLST("PRIO",ABMIPRI))
IF +ABMIPRI=0
QUIT
Begin DoDot:1
+21 SET ABMIIEN=0
+22 FOR
SET ABMIIEN=$ORDER(ABMLST("PRIO",ABMIPRI,ABMIIEN))
IF +ABMIIEN=0
QUIT
Begin DoDot:2
+23 SET ABMCAT=""
+24 FOR
SET ABMCAT=$ORDER(ABMLST("TRANS",ABMIIEN,ABMCAT))
IF ABMCAT=""
QUIT
Begin DoDot:3
+25 SET ABMLN=0
+26 FOR
SET ABMLN=$ORDER(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN))
IF +ABMLN=0
QUIT
Begin DoDot:4
+27 SET ABMTREC=$GET(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN))
+28 IF $PIECE(ABMTREC,U,5)="Y"
SET ABMP("CBAMT")=ABMP("CBAMT")+($FNUMBER($PIECE(ABMTREC,U),"-"))
+29 IF ABMCAT="P"
SET ABMPM("PD")=+$GET(ABMPM("PD"))+($PIECE(ABMTREC,U))
+30 IF ABMCAT="A"
Begin DoDot:5
+31 SET ABMATYP=$PIECE(ABMTREC,U,2)
+32 SET ABMAAMT=$PIECE(ABMTREC,U)
+33 IF ABMATYP=3
SET ABMPM("WO")=+$GET(ABMPM("WO"))+ABMAAMT
+34 IF ABMATYP=4
SET ABMPM("NONC")=+$GET(ABMPM("NONC"))+ABMAAMT
+35 IF ABMATYP=13
SET ABMPM("DED")=+$GET(ABMPM("DED"))+ABMAAMT
+36 IF ABMATYP=14
SET ABMPM("COI")=+$GET(ABMPM("COI"))+ABMAAMT
+37 IF ABMATYP=15
SET ABMPM("PENS")=+$GET(ABMPM("PENS"))+ABMAAMT
+38 IF ABMATYP=16
SET ABMPM("GRP")=+$GET(ABMPM("GRP"))+ABMAAMT
+39 IF ABMATYP=19
SET ABMPM("REF")=+$GET(ABMPM("REF"))+ABMAAMT
+40 IF ABMATYP=20
SET ABMPM("PCR")=+$GET(ABMPM("PCR"))+ABMAAMT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 WRITE !,"Payment Amount....: "
SET ABMNFLG=1
WRITE $$DOLAMT(ABMPM("PD"))
KILL ABMNFLG
+43 WRITE ?40,"Deductible Amount.: ",$$DOLAMT(ABMPM("DED"))
+44 WRITE !,"Payment Credits...: ",$$DOLAMT(ABMPM("PCR"))
+45 WRITE ?40,"Co-pay/ins Amount.: ",$$DOLAMT(ABMPM("COI"))
+46 WRITE !?40,"Write Off.........: ",$$DOLAMT(ABMPM("WO"))
+47 WRITE !,"Refund............: ",$$DOLAMT(ABMPM("REF"))
+48 WRITE ?40,"Non-Covered Amount: ",$$DOLAMT(ABMPM("NONC"))
+49 WRITE !?40,"Penalty Amount....: ",$$DOLAMT(ABMPM("PENS"))
+50 WRITE !?40,"Grouper Allowance.: ",$$DOLAMT(ABMPM("GRP"))
+51 ;abm*2.6*11 HEAT81390
SET ABMRVFLG=1
+52 ;
+53 SET ABMPRI=0
+54 FOR
SET ABMPRI=$ORDER(ABMLST("PRIO",ABMPRI))
IF +ABMPRI=0
QUIT
Begin DoDot:1
+55 SET ABMIIEN=0
+56 SET ABMPRIS=ABMPRI
+57 FOR
SET ABMIIEN=$ORDER(ABMLST("PRIO",ABMPRI,ABMIIEN))
IF +ABMIIEN=0
QUIT
Begin DoDot:2
+58 SET ABMSTAT=$PIECE(ABMLST("PRIO",ABMPRI,ABMIIEN),U,2)
+59 SET ABMINS=$PIECE(ABMLST("PRIO",ABMPRI,ABMIIEN),U)
+60 SET ABMSTAT=$SELECT(ABMSTAT="F":"FLAGGED",ABMSTAT="I":"ACTIVE",ABMSTAT="P":"PENDING",ABMSTAT="U":"UNBILLABLE",ABMSTAT="C":"COMPLETED",ABMSTAT="B":"BILLED",ABMSTAT="L":"PARTIAL",1:"")
+61 WRITE !!,"["_ABMPRI_"] INSURER: ",$EXTRACT($PIECE($GET(^AUTNINS(ABMIIEN,0)),U),1,27)
+62 WRITE ?40,"PRIORITY ORDER: ",ABMPRI
+63 WRITE ?62,"STATUS: "
+64 WRITE $SELECT(ABMSTAT="COMPLETED":$$EN^ABMVDF("RVN"),1:""),ABMSTAT,$SELECT(ABMSTAT="COMPLETED":$$EN^ABMVDF("RVF"),1:"")
+65 SET ABMCOV=0
+66 FOR
SET ABMCOV=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,11,ABMCOV))
IF +ABMCOV=0
QUIT
Begin DoDot:3
+67 IF $PIECE($GET(^AUTNINS(ABMIIEN,0)),U)["MEDICARE"
Begin DoDot:4
+68 WRITE !?14,"COVERAGE TYPE: ",$PIECE($GET(^AUTTPIC(ABMCOV,0)),U)
+69 SET ABMCOV=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,11,ABMCOV))
+70 IF +ABMCOV'=0
WRITE ", ",$PIECE($GET(^AUTTPIC(ABMCOV,0)),U)
End DoDot:4
+71 IF '$TEST
WRITE !?14,"COVERAGE TYPE: ",$PIECE($GET(^AUTTPIC(ABMCOV,0)),U)
End DoDot:3
+72 SET ABMCAT=""
+73 FOR
SET ABMCAT=$ORDER(ABMLST("TRANS",ABMIIEN,ABMCAT),-1)
IF ABMCAT=""
QUIT
Begin DoDot:3
+74 SET ABMLN=0
+75 FOR
SET ABMLN=$ORDER(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN))
IF +ABMLN=0
QUIT
Begin DoDot:4
+76 IF +$PIECE(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN),U)=0
QUIT
+77 IF +$GET(ABMLNSV)<ABMLN
SET ABMLNSV=ABMLN
+78 SET ABMDAMT=$PIECE($GET(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN)),U)
+79 IF ABMCAT="P"
SET ABMNFLG=1
+80 SET ABMDAMT=$$DOLAMT(ABMDAMT)
+81 KILL ABMNFLG
+82 IF ABMCAT="P"
WRITE !?6,"PYMT: ",ABMDAMT
+83 IF '$TEST
DO ADJS
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+84 WRITE !,ABMDASH,!
+85 IF ("^21^22^23^31^32^33^"[("^"_ABMP("EXP")_"^"))
Begin DoDot:1
+86 IF $GET(ABMSFLG)=1
WRITE "ERROR: STANDARD ADJUSTMENT CODE NOT ENTERED FOR ADJUSTMENT",!
+87 IF $GET(ABMMFLG)=1
WRITE "ERROR: STANDARD ADJUSTMENT REASON DOESN'T MATCH ADJUSTMENT CATEGORY/REASON",!
+88 IF ABMP("CBAMT")<0
WRITE "ERROR: NEGATIVE BALANCE ON BILL NOT ALLOWED",!
SET ABMSFLG=1
+89 IF $GET(ABMSFLG)=1!($GET(ABMMFLG)=1)
WRITE ABMDASH,!
+90 IF $GET(ABMSFLG)=1
WRITE "**Use the EDIT option to populate the Standard Adjustment Reason Code**",!
End DoDot:1
+91 ;remove flag for other checks of this error
IF '$TEST
KILL ABMSFLG,ABMMFLG
+92 ;
+93 SET ABMP("OPT")="AERSQ"
+94 SET ABMP("DFLT")="Q"
+95 DO SEL
+96 IF "AERS"'[$EXTRACT(Y)
DO XIT^ABMPPADJ
QUIT
+97 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
DO XIT^ABMPPADJ
QUIT
+98 SET ABM("DO")=$SELECT($EXTRACT(Y)="A":"ADD^ABMPPADJ",$EXTRACT(Y)="E":"EDIT^ABMPPADJ",$EXTRACT(Y)="R":"RESTR^ABMPPADJ",$EXTRACT(Y)="S":"EN^ABMPPFLR",1:"XIT^ABMPPADJ")
DO @ABM("DO")
+99 GOTO DISP
+100 QUIT
ADJS ;EP
+1 WRITE !?7,"ADJ: ",ABMDAMT
+2 SET ABMPREC=$GET(ABMLST("TRANS",ABMIIEN,ABMCAT,ABMLN))
+3 ;I $P(ABMPREC,U,5)="Y" W ?24,"<B>"
+4 ;I $P(ABMPREC,U,5)="N" W ?24,"<N>"
+5 IF $PIECE(ABMPREC,U,2)'=""
WRITE ?28,"[",$PIECE(ABMPREC,U,2),"] ",$EXTRACT($PIECE($GET(^BAR(90052.01,$PIECE(ABMPREC,U,2),0)),U),1,18)
+6 IF $PIECE(ABMPREC,U,3)'=""
WRITE ?47,"[",$PIECE(ABMPREC,U,3),"] ",$EXTRACT($PIECE($GET(^BARTBL($PIECE(ABMPREC,U,3),0)),U),1,18)
+7 IF $PIECE($GET(ABMPREC),U,4)'=""
Begin DoDot:1
+8 WRITE ?75,"["_$PIECE(^BARADJ($PIECE($GET(ABMPREC),U,4),0),U)_"]"
+9 IF $PIECE(^BARADJ($PIECE(ABMPREC,U,4),0),U,3)'=$PIECE(ABMPREC,U,2)
SET ABMMFLG=1
+10 IF $PIECE(^BARADJ($PIECE(ABMPREC,U,4),0),U,4)'=$PIECE(ABMPREC,U,3)
SET ABMMFLG=1
End DoDot:1
+11 IF $PIECE($GET(ABMPREC),U,4)=""
IF ($PIECE(ABMPREC,U)'=0)
SET ABMSFLG=1
+12 QUIT
DOLAMT(AMT) ;
+1 QUIT $SELECT(($EXTRACT(AMT,1)="-"!($GET(ABMNFLG)=1))&(AMT'=0):"("_$JUSTIFY($SELECT($EXTRACT(AMT)="-":$EXTRACT(AMT,2,$LENGTH(AMT)),1:AMT),10,2)_")",1:$JUSTIFY(+$GET(AMT),11,2))
+2 ;
SEL ;EP for Page Commands, Desired Action Controller
+1 IF $DATA(ABMP("DDL"))
IF $DATA(ABMP("QUIT"))
SET Y="Q"
GOTO XIT
+2 IF '$DATA(ABMP("DFLT"))
SET ABMP("DFLT")=""
+3 KILL %P,DIR
SET DIR(0)="F^1:9"
+4 SET (DIR("B"),ABMO("DFLT"))=$SELECT(ABMP("DFLT")]"":ABMP("DFLT"),ABMP("OPT")'["N":"B",1:"N")
+5 SET DIR("A")="Desired ACTION ("
+6 SET DIR("?",1)=" Choose from one of the following actions:"
+7 SET DIR("?",2)=" "
+8 FOR ABMO("CTR")=3:1
SET ABMO("TXT")=$EXTRACT(ABMP("OPT"),ABMO("CTR")-2)
IF ABMO("TXT")=""
QUIT
Begin DoDot:1
+9 IF $DATA(ABMP("VIEWMODE"))
IF "NVBJQ"'[ABMO("TXT")
QUIT
+10 SET DIR("?",ABMO("CTR"))=$PIECE($TEXT(@ABMO("TXT")),";;",2)
SET DIR("A")=DIR("A")_$PIECE($TEXT(@ABMO("TXT")),";;",3)_"/"
End DoDot:1
+11 SET DIR("?",ABMO("CTR"))=" "
+12 SET DIR("?")=" Enter First Character of the Desired Action."
+13 SET DIR("A")=$PIECE(DIR("A"),"/",1,$LENGTH(DIR("A"),"/")-1)_")"
+14 DO ^DIR
KILL DIR
+15 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO XIT
+16 IF X=""
SET Y=ABMO("DFLT")
+17 SET Y=$$UPC^ABMERUTL(Y)
+18 IF $EXTRACT(X)="?"
DO ^ABMDEHLP
GOTO SEL
+19 IF '+$EXTRACT(Y)
IF '+$EXTRACT(Y,2)
IF $EXTRACT(Y,2)'=0
SET Y=$EXTRACT(Y)
+20 IF $ASCII(Y,1)>96&($ASCII(Y,1)<123)
SET Y=$CHAR($ASCII(Y,1)-32)_$EXTRACT(Y,2,99)
+21 IF ABMP("OPT")[$EXTRACT(Y)
KILL ABMP("DFLT")
GOTO XIT
+22 IF +Y
IF $DATA(ABMZ("NUM"))
IF Y<(ABMZ("NUM")+1)
KILL ABMP("DFLT")
SET Y="E"_+Y
GOTO XIT
+23 WRITE *7
GOTO SEL
+24 ;
A ;; Add - Add a New Entry;;Add
E ;; Edit - Edit Information in the Current Screen;;Edit
R ;; Rstr - Restore transactions from A/R;;Restore
S ;; Save - Save transactions;;Save
Q ;; Quit - Stop Editing the Data;;Quit
+1 ;
FLDS ;EP for Field Edit Controller
+1 SET ABMO("Y")=+$EXTRACT(Y,2,3)
IF ABMO("Y")>0&(ABMO("Y")<(ABMP("FLDS")+1))
SET Y=ABMO("Y")
GOTO EJ
+2 WRITE !
SET DIR(0)="LO^1:"_ABMP("FLDS")
SET DIR("A")="Desired FIELDS"
SET DIR("B")="1-"_ABMP("FLDS")
DO ^DIR
KILL DIR
+3 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO XIT
EJ SET ABMP("FLDS")=Y
+1 GOTO XIT
+2 ;
XIT KILL ABMO,ABMP("OPT")
+1 QUIT
