Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSUSC

ACHSUSC.m

Go to the documentation of this file. 
  1. 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
  1.  ;3.1*6 6/13/03 IHS/SET/FCJ 3RD PARTY NOT PRINTING
  1.  ;
  1.  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
  1. A0 ;
  1.  D ^ACHSUD                              ;SELECT DOCUMENT
  1.  I $D(DUOUT)!$D(DTOUT)!'$D(ACHSDIEN) D END Q
  1.  S ACHSTIEN=1
  1.  K ACHSSIG
  1.  D INIT^ACHSRP2                       ;INITIALIZE VARS  
  1.  D ^ACHSAV                            ;INIT VARS, OPTS
  1.  ;
  1. A0A ;EP.
  1.  S (S,C,A,A("DT"),ACHSIPP3,ACHSZC,ACHSZA,ACHSZA1,B)=""
  1.  ;
  1.  ;GET 'IHS PAYMENT AMOUNT' FROM INITIAL TRANSACTION
  1.  S ACHSPAYA=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",1,0)),U,4)  ;'IHS PAYMENT AMOUNT'
  1.  ;
  1. A1 ;
  1.  S (ACHSTR0,ACHSTTYP)=ACHSNOTF
  1.  S ACHSTRAN=1   ;SKIP FIRST TRANSACTION ;ASSUME ITS INITIAL ?????
  1.  F  S ACHSTRAN=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTRAN)) Q:+ACHSTRAN=0  D
  1.  .S ACHSTR0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTRAN,0))  ;TRAN 0 NODE
  1.  .S ACHSTTYP=$P(ACHSTR0,U,2)           ;TRANSACTION TYPE
  1.  .;
  1.  .;ADD UP SUPP. 'IHS PAYMENT AMOUNTS' AND GET 'TRANSACTION DATES' 
  1.  .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
  1.  .;
  1.  .;ADD UP CANCEL 'IHS PAYMENT AMOUNTS'
  1.  .I ACHSTTYP="C" S C=C+1 S B=B+$P(ACHSTR0,U,4) Q
  1.  .;
  1.  .;ADD UP ADJUSTMENT 'IHS PAYMENT AMOUNTS'
  1.  .;ACHS*3.1*6 6/13/03 IHS/SET/FCJ 3RD PARTY NOT PRINTING
  1.  .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
  1.  .;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
  1.  .I ACHSTTYP="IP" S ACHSIPP3=ACHSIPP3+$P(ACHSTR0,U,8) Q
  1.  .;
  1.  ;
  1. B1 ;WRITE TOTALS FOUND ABOVE
  1.  W !?4,"Initial Obligation",?30,$J(ACHSPAYA,8,2)
  1.  ;
  1.  W !?4,"Amount Canceled:",?30,$J("-"_B,8,2),?40,"(",C," Item",$S(C=1:"",1:"s"),")"
  1.  W !?4,"Amount Of Supplements",?30,$J("+"_A,8,2),?40,"(",A("DT")," )"
  1.  ;
  1. B2 ;
  1.  S ACHSBAL=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,9)
  1.  W !?30,"--------",!,"CURRENT OBLIGATION BALANCE",?30,$J(ACHSBAL,8,2)
  1.  ;
  1.  ;IF WHAT?????
  1.  ;I (C+ACHSZC+ACHSIPP3)
  1.  ;!($D(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP")))
  1.  ;!($D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")))
  1.  W ?46,"(IHS)",?52,"(3rd PARTY)"
  1.  ;
  1.  ;IF WE HAVE AND ENTRY IN THE INTERIM PAYMENT NODE
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP")) D
  1.  .S ACHSIPP=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U) ;'INTERIM PAYMENT TOTAL'
  1.  .S ACHSIPN=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U,2) ;# OF INTERIM PAYMENTS
  1.  .S ACHSIPDT=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U,3) ;LAST INTERIM PAYMENT DATE
  1.  .S ACHSIPDT=$E(ACHSIPDT,4,5)_"/"_$E(ACHSIPDT,6,7)_"/"_$E(ACHSIPDT,2,3)
  1.  ;
  1.  ;IF WE HAVE AN ENTRY IN THE PAYMENT NODE
  1.  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
  1.  ;
  1.  ;
  1.  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
  1.  ;
  1. B2A ;
  1.  G BC:+$P(ACHSDOC0,U,12)=4 ;'STATUS' = CANCELED
  1.  ;
  1.  ;GO THROUGH THE TRANSACTIONS AGAIN AND GET PAYMENTS
  1.  S R=0,X=""
  1.  ;
  1. B3 ;
  1.  S R=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R)) G B4:R="" I '$D(^(R,0)) G B4
  1.  S X=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R,0),U,2)
  1.  I X'="P" G B3
  1. B4 ;
  1.  I X'="P" K ACHSIPP,ACHSIPN,ACHSIPDT D END Q
  1.  G B5:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"))
  1.  I ACHSZC W !?17,"Amount of Adjustments:",$$FMT(ACHSZA),$$FMT(ACHSZA1)," (",ACHSZC," Item",$S(ACHSZC=1:"",1:"s"),")"
  1. B5 ;
  1.  S Y=$$DOC^ACHS("PA",3),ACHS(1)=$$DOC^ACHS("PA",6),ACHS(2)=$$DOC^ACHS("PA",5)
  1.  W !?9,"FINAL PAYMENT ON ",$$FMTE^XLFDT(Y),":",$$FMT(ACHS(1)),$$FMT(ACHS(2))
  1.  I $$PARM^ACHS(0,8)="Y",$L($$DOC^ACHS(2,2)) W !?31,"CHECK #:",$J($$DOC^ACHS(2,2),12)
  1.  ;ACHS*3.1*17 2/1/2010 OIT.IHS.FCJ ADDED NXT LINE TO PRINT THE PRINT DATE OF CHECK
  1.  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)
  1.  S ACHSDOCT=$$DOC^ACHS("PA",1)    ;'TOTAL PAYMENT AMOUNT'
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")) S ACHSDOCT=$P(^("ZA"),U)
  1.  W !?24,"TOTAL PAYMENTS:",$$FMT(ACHSDOCT),$$FMT(ACHS(2)+ACHSZA1+ACHSIPP3)
  1.  K X2,X3
  1.  G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) C1
  1.  I +ACHSZC=0,$$DOC^ACHS("PA",4)="I" G C1
  1.  G ENDA:'$D(ACHSADJ),END
  1.  ;
  1. BC ;
  1.  S X="",R=0
  1. BC5 ;
  1.  S R=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",R)) G BC6:R="",BC6:'$D(^(R,0)) S X=$P(^(0),U,2)
  1.  I X'="C" G BC5
  1. BC6 ;
  1.  I X'="C" G ENDA
  1.  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))
  1.  G ENDA
  1.  ;
  1. C1 ;
  1.  Q:$D(ACHSVIEW)
  1.  W:$Y<20 !
  1.  I $$DIR^XBDIR("Y","Is This The Correct Document","YES","","","",1)
  1.  G END:$D(DTOUT),ENDA:$D(DUOUT)
  1. ENDA ;
  1.  K ACHSIPP,ACHSIPN,ACHSIPD
  1.  Q:$D(ACHSDVEW)
  1.  G A0
  1.  ;
  1. END ;
  1.  K ACHSZA,ACHSZC
  1.  Q
  1.  ;
  1. FMT(X) ;
  1.  Q $J("",12-$L($FN(X,",",2)))_$FN(X,",",2)