ACHSUSC ; IHS/ITSC/PMF - DISPLAY DOCUMENT CANCEL/SUPPLEMENTAL INFO ; [ 10/31/2003 12:13 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,17**;JUNE 11, 2001
;3.1*6 6/13/03 IHS/SET/FCJ 3RD PARTY NOT PRINTING
;
I '$D(ACHSVIEW),$D(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0)),$P(^(0),U,2)=DT W !!,*7," The Register Has Been CLOSED." H 3 G END
A0 ;
D ^ACHSUD ;SELECT DOCUMENT
I $D(DUOUT)!$D(DTOUT)!'$D(ACHSDIEN) D END Q
S ACHSTIEN=1
K ACHSSIG
D INIT^ACHSRP2 ;INITIALIZE VARS
D ^ACHSAV ;INIT VARS, OPTS
;
A0A ;EP.
S (S,C,A,A("DT"),ACHSIPP3,ACHSZC,ACHSZA,ACHSZA1,B)=""
;
;GET 'IHS PAYMENT AMOUNT' FROM INITIAL TRANSACTION
S ACHSPAYA=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",1,0)),U,4) ;'IHS PAYMENT AMOUNT'
;
A1 ;
S (ACHSTR0,ACHSTTYP)=ACHSNOTF
S ACHSTRAN=1 ;SKIP FIRST TRANSACTION ;ASSUME ITS INITIAL ?????
F S ACHSTRAN=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTRAN)) Q:+ACHSTRAN=0 D
.S ACHSTR0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTRAN,0)) ;TRAN 0 NODE
.S ACHSTTYP=$P(ACHSTR0,U,2) ;TRANSACTION TYPE
.;
.;ADD UP SUPP. 'IHS PAYMENT AMOUNTS' AND GET 'TRANSACTION DATES'
.I ACHSTTYP="S" S S=S+1 S A=A+$P(ACHSTR0,U,4) S A("DT")=A("DT")_" "_$E($P(ACHSTR0,U),4,5)_"-"_$E($P(ACHSTR0,U),6,7)_"-"_$E($P(ACHSTR0,U),2,3) Q
.;
.;ADD UP CANCEL 'IHS PAYMENT AMOUNTS'
.I ACHSTTYP="C" S C=C+1 S B=B+$P(ACHSTR0,U,4) Q
.;
.;ADD UP ADJUSTMENT 'IHS PAYMENT AMOUNTS'
.;ACHS*3.1*6 6/13/03 IHS/SET/FCJ 3RD PARTY NOT PRINTING
.I ACHSTTYP="ZA" S ACHSZC=ACHSZC+1 S ACHSZA=ACHSZA+$P(ACHSTR0,U,4) S ACHSZA1=ACHSZA1+$P(ACHSTR0,U,8) Q ;ACHS*3.1*6 6/13/03
.;I ACHSTTYP="ZA" S ACHSZC=ACHSZC+1 S ACHSZA=ACHSZA+$P(ACHSTR0,U,4) S ACHSZA1=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"),U,4) Q ;ACHS*3.1*6 6/13/03
.I ACHSTTYP="IP" S ACHSIPP3=ACHSIPP3+$P(ACHSTR0,U,8) Q
.;
;
B1 ;WRITE TOTALS FOUND ABOVE
W !?4,"Initial Obligation",?30,$J(ACHSPAYA,8,2)
;
W !?4,"Amount Canceled:",?30,$J("-"_B,8,2),?40,"(",C," Item",$S(C=1:"",1:"s"),")"
W !?4,"Amount Of Supplements",?30,$J("+"_A,8,2),?40,"(",A("DT")," )"
;
B2 ;
S ACHSBAL=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,9)
W !?30,"--------",!,"CURRENT OBLIGATION BALANCE",?30,$J(ACHSBAL,8,2)
;
;IF WHAT?????
;I (C+ACHSZC+ACHSIPP3)
;!($D(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP")))
;!($D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")))
W ?46,"(IHS)",?52,"(3rd PARTY)"
;
;IF WE HAVE AND ENTRY IN THE INTERIM PAYMENT NODE
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP")) D
.S ACHSIPP=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U) ;'INTERIM PAYMENT TOTAL'
.S ACHSIPN=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U,2) ;# OF INTERIM PAYMENTS
.S ACHSIPDT=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U,3) ;LAST INTERIM PAYMENT DATE
.S ACHSIPDT=$E(ACHSIPDT,4,5)_"/"_$E(ACHSIPDT,6,7)_"/"_$E(ACHSIPDT,2,3)
;
;IF WE HAVE AN ENTRY IN THE PAYMENT NODE
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),$D(ACHSIPP) W !?5,$S(ACHSIPN<2:" ",1:""),ACHSIPN W " Interim Payment",$S(ACHSIPN<2:"",1:"s") W " for a Total of:",$$FMT(ACHSIPP),$$FMT(ACHSIPP3) G B2A
;
;
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP")),$D(ACHSIPP) W !?5,$S(ACHSIPN<2:" ",1:""),ACHSIPN," Interim Payment",$S(ACHSIPN<2:"",1:"s")," for a Total of:",$$FMT(ACHSIPP),$$FMT(ACHSIPP3),", as of ",ACHSIPDT
;
B2A ;
G BC:+$P(ACHSDOC0,U,12)=4 ;'STATUS' = CANCELED
;
;GO THROUGH THE TRANSACTIONS AGAIN AND GET PAYMENTS
S R=0,X=""
;
B3 ;
S R=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R)) G B4:R="" I '$D(^(R,0)) G B4
S X=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R,0),U,2)
I X'="P" G B3
B4 ;
I X'="P" K ACHSIPP,ACHSIPN,ACHSIPDT D END Q
G B5:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"))
I ACHSZC W !?17,"Amount of Adjustments:",$$FMT(ACHSZA),$$FMT(ACHSZA1)," (",ACHSZC," Item",$S(ACHSZC=1:"",1:"s"),")"
B5 ;
S Y=$$DOC^ACHS("PA",3),ACHS(1)=$$DOC^ACHS("PA",6),ACHS(2)=$$DOC^ACHS("PA",5)
W !?9,"FINAL PAYMENT ON ",$$FMTE^XLFDT(Y),":",$$FMT(ACHS(1)),$$FMT(ACHS(2))
I $$PARM^ACHS(0,8)="Y",$L($$DOC^ACHS(2,2)) W !?31,"CHECK #:",$J($$DOC^ACHS(2,2),12)
;ACHS*3.1*17 2/1/2010 OIT.IHS.FCJ ADDED NXT LINE TO PRINT THE PRINT DATE OF CHECK
I $$PARM^ACHS(0,8)="Y",$L($$DOC^ACHS(2,3)) S Y=$$DOC^ACHS(2,3) W !?9,"DATE CHECK WAS ISSUED: ",$$FMTE^XLFDT(Y)
S ACHSDOCT=$$DOC^ACHS("PA",1) ;'TOTAL PAYMENT AMOUNT'
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")) S ACHSDOCT=$P(^("ZA"),U)
W !?24,"TOTAL PAYMENTS:",$$FMT(ACHSDOCT),$$FMT(ACHS(2)+ACHSZA1+ACHSIPP3)
K X2,X3
G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) C1
I +ACHSZC=0,$$DOC^ACHS("PA",4)="I" G C1
G ENDA:'$D(ACHSADJ),END
;
BC ;
S X="",R=0
BC5 ;
S R=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R)) G BC6:R="",BC6:'$D(^(R,0)) S X=$P(^(0),U,2)
I X'="C" G BC5
BC6 ;
I X'="C" G ENDA
W *7,!!,"DOCUMENT CANCELLED ON ",$$FMTE^XLFDT($P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R,0),U)),", Reason: ",$$EXTSET^XBFUNC(9002080.01,63,$$DOC^ACHS(2,8))
G ENDA
;
C1 ;
Q:$D(ACHSVIEW)
W:$Y<20 !
I $$DIR^XBDIR("Y","Is This The Correct Document","YES","","","",1)
G END:$D(DTOUT),ENDA:$D(DUOUT)
ENDA ;
K ACHSIPP,ACHSIPN,ACHSIPD
Q:$D(ACHSDVEW)
G A0
;
END ;
K ACHSZA,ACHSZC
Q
;
FMT(X) ;
Q $J("",12-$L($FN(X,",",2)))_$FN(X,",",2)
ACHSUSC ; IHS/ITSC/PMF - DISPLAY DOCUMENT CANCEL/SUPPLEMENTAL INFO ; [ 10/31/2003 12:13 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,17**;JUNE 11, 2001
+2 ;3.1*6 6/13/03 IHS/SET/FCJ 3RD PARTY NOT PRINTING
+3 ;
+4 IF '$DATA(ACHSVIEW)
IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0))
IF $PIECE(^(0),U,2)=DT
WRITE !!,*7," The Register Has Been CLOSED."
HANG 3
GOTO END
A0 ;
+1 ;SELECT DOCUMENT
DO ^ACHSUD
+2 IF $DATA(DUOUT)!$DATA(DTOUT)!'$DATA(ACHSDIEN)
DO END
QUIT
+3 SET ACHSTIEN=1
+4 KILL ACHSSIG
+5 ;INITIALIZE VARS
DO INIT^ACHSRP2
+6 ;INIT VARS, OPTS
DO ^ACHSAV
+7 ;
A0A ;EP.
+1 SET (S,C,A,A("DT"),ACHSIPP3,ACHSZC,ACHSZA,ACHSZA1,B)=""
+2 ;
+3 ;GET 'IHS PAYMENT AMOUNT' FROM INITIAL TRANSACTION
+4 ;'IHS PAYMENT AMOUNT'
SET ACHSPAYA=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",1,0)),U,4)
+5 ;
A1 ;
+1 SET (ACHSTR0,ACHSTTYP)=ACHSNOTF
+2 ;SKIP FIRST TRANSACTION ;ASSUME ITS INITIAL ?????
SET ACHSTRAN=1
+3 FOR
SET ACHSTRAN=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTRAN))
IF +ACHSTRAN=0
QUIT
Begin DoDot:1
+4 ;TRAN 0 NODE
SET ACHSTR0=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTRAN,0))
+5 ;TRANSACTION TYPE
SET ACHSTTYP=$PIECE(ACHSTR0,U,2)
+6 ;
+7 ;ADD UP SUPP. 'IHS PAYMENT AMOUNTS' AND GET 'TRANSACTION DATES'
+8 IF ACHSTTYP="S"
SET S=S+1
SET A=A+$PIECE(ACHSTR0,U,4)
SET A("DT")=A("DT")_" "_$EXTRACT($PIECE(ACHSTR0,U),4,5)_"-"_$EXTRACT($PIECE(ACHSTR0,U),6,7)_"-"_$EXTRACT($PIECE(ACHSTR0,U),2,3)
QUIT
+9 ;
+10 ;ADD UP CANCEL 'IHS PAYMENT AMOUNTS'
+11 IF ACHSTTYP="C"
SET C=C+1
SET B=B+$PIECE(ACHSTR0,U,4)
QUIT
+12 ;
+13 ;ADD UP ADJUSTMENT 'IHS PAYMENT AMOUNTS'
+14 ;ACHS*3.1*6 6/13/03 IHS/SET/FCJ 3RD PARTY NOT PRINTING
+15 ;ACHS*3.1*6 6/13/03
IF ACHSTTYP="ZA"
SET ACHSZC=ACHSZC+1
SET ACHSZA=ACHSZA+$PIECE(ACHSTR0,U,4)
SET ACHSZA1=ACHSZA1+$PIECE(ACHSTR0,U,8)
QUIT
+16 ;I ACHSTTYP="ZA" S ACHSZC=ACHSZC+1 S ACHSZA=ACHSZA+$P(ACHSTR0,U,4) S ACHSZA1=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"),U,4) Q ;ACHS*3.1*6 6/13/03
+17 IF ACHSTTYP="IP"
SET ACHSIPP3=ACHSIPP3+$PIECE(ACHSTR0,U,8)
QUIT
+18 ;
End DoDot:1
+19 ;
B1 ;WRITE TOTALS FOUND ABOVE
+1 WRITE !?4,"Initial Obligation",?30,$JUSTIFY(ACHSPAYA,8,2)
+2 ;
+3 WRITE !?4,"Amount Canceled:",?30,$JUSTIFY("-"_B,8,2),?40,"(",C," Item",$SELECT(C=1:"",1:"s"),")"
+4 WRITE !?4,"Amount Of Supplements",?30,$JUSTIFY("+"_A,8,2),?40,"(",A("DT")," )"
+5 ;
B2 ;
+1 SET ACHSBAL=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,9)
+2 WRITE !?30,"--------",!,"CURRENT OBLIGATION BALANCE",?30,$JUSTIFY(ACHSBAL,8,2)
+3 ;
+4 ;IF WHAT?????
+5 ;I (C+ACHSZC+ACHSIPP3)
+6 ;!($D(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP")))
+7 ;!($D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")))
+8 WRITE ?46,"(IHS)",?52,"(3rd PARTY)"
+9 ;
+10 ;IF WE HAVE AND ENTRY IN THE INTERIM PAYMENT NODE
+11 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"))
Begin DoDot:1
+12 ;'INTERIM PAYMENT TOTAL'
SET ACHSIPP=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U)
+13 ;# OF INTERIM PAYMENTS
SET ACHSIPN=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U,2)
+14 ;LAST INTERIM PAYMENT DATE
SET ACHSIPDT=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U,3)
+15 SET ACHSIPDT=$EXTRACT(ACHSIPDT,4,5)_"/"_$EXTRACT(ACHSIPDT,6,7)_"/"_$EXTRACT(ACHSIPDT,2,3)
End DoDot:1
+16 ;
+17 ;IF WE HAVE AN ENTRY IN THE PAYMENT NODE
+18 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
IF $DATA(ACHSIPP)
WRITE !?5,$SELECT(ACHSIPN<2:" ",1:""),ACHSIPN
WRITE " Interim Payment",$SELECT(ACHSIPN<2:"",1:"s")
WRITE " for a Total of:",$$FMT(ACHSIPP),$$FMT(ACHSIPP3)
GOTO B2A
+19 ;
+20 ;
+21 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"))
IF $DATA(ACHSIPP)
WRITE !?5,$SELECT(ACHSIPN<2:" ",1:""),ACHSIPN," Interim Payment",$SELECT(ACHSIPN<2:"",1:"s")," for a Total of:",$$FMT(ACHSIPP),$$FMT(ACHSIPP3),", as of ",ACHSIPDT
+22 ;
B2A ;
+1 ;'STATUS' = CANCELED
IF +$PIECE(ACHSDOC0,U,12)=4
GOTO BC
+2 ;
+3 ;GO THROUGH THE TRANSACTIONS AGAIN AND GET PAYMENTS
+4 SET R=0
SET X=""
+5 ;
B3 ;
+1 SET R=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R))
IF R=""
GOTO B4
IF '$DATA(^(R,0))
GOTO B4
+2 SET X=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R,0),U,2)
+3 IF X'="P"
GOTO B3
B4 ;
+1 IF X'="P"
KILL ACHSIPP,ACHSIPN,ACHSIPDT
DO END
QUIT
+2 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"))
GOTO B5
+3 IF ACHSZC
WRITE !?17,"Amount of Adjustments:",$$FMT(ACHSZA),$$FMT(ACHSZA1)," (",ACHSZC," Item",$SELECT(ACHSZC=1:"",1:"s"),")"
B5 ;
+1 SET Y=$$DOC^ACHS("PA",3)
SET ACHS(1)=$$DOC^ACHS("PA",6)
SET ACHS(2)=$$DOC^ACHS("PA",5)
+2 WRITE !?9,"FINAL PAYMENT ON ",$$FMTE^XLFDT(Y),":",$$FMT(ACHS(1)),$$FMT(ACHS(2))
+3 IF $$PARM^ACHS(0,8)="Y"
IF $LENGTH($$DOC^ACHS(2,2))
WRITE !?31,"CHECK #:",$JUSTIFY($$DOC^ACHS(2,2),12)
+4 ;ACHS*3.1*17 2/1/2010 OIT.IHS.FCJ ADDED NXT LINE TO PRINT THE PRINT DATE OF CHECK
+5 IF $$PARM^ACHS(0,8)="Y"
IF $LENGTH($$DOC^ACHS(2,3))
SET Y=$$DOC^ACHS(2,3)
WRITE !?9,"DATE CHECK WAS ISSUED: ",$$FMTE^XLFDT(Y)
+6 ;'TOTAL PAYMENT AMOUNT'
SET ACHSDOCT=$$DOC^ACHS("PA",1)
+7 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"))
SET ACHSDOCT=$PIECE(^("ZA"),U)
+8 WRITE !?24,"TOTAL PAYMENTS:",$$FMT(ACHSDOCT),$$FMT(ACHS(2)+ACHSZA1+ACHSIPP3)
+9 KILL X2,X3
+10 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
GOTO C1
+11 IF +ACHSZC=0
IF $$DOC^ACHS("PA",4)="I"
GOTO C1
+12 IF '$DATA(ACHSADJ)
GOTO ENDA
GOTO END
+13 ;
BC ;
+1 SET X=""
SET R=0
BC5 ;
+1 SET R=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R))
IF R=""
GOTO BC6
IF '$DATA(^(R,0))
GOTO BC6
SET X=$PIECE(^(0),U,2)
+2 IF X'="C"
GOTO BC5
BC6 ;
+1 IF X'="C"
GOTO ENDA
+2 WRITE *7,!!,"DOCUMENT CANCELLED ON ",$$FMTE^XLFDT($PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R,0),U)),", Reason: ",$$EXTSET^XBFUNC(9002080.01,63,$$DOC^ACHS(2,8))
+3 GOTO ENDA
+4 ;
C1 ;
+1 IF $DATA(ACHSVIEW)
QUIT
+2 IF $Y<20
WRITE !
+3 IF $$DIR^XBDIR("Y","Is This The Correct Document","YES","","","",1)
+4 IF $DATA(DTOUT)
GOTO END
IF $DATA(DUOUT)
GOTO ENDA
ENDA ;
+1 KILL ACHSIPP,ACHSIPN,ACHSIPD
+2 IF $DATA(ACHSDVEW)
QUIT
+3 GOTO A0
+4 ;
END ;
+1 KILL ACHSZA,ACHSZC
+2 QUIT
+3 ;
FMT(X) ;
+1 QUIT $JUSTIFY("",12-$LENGTH($FNUMBER(X,",",2)))_$FNUMBER(X,",",2)
