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

ACHS3PP2.m

Go to the documentation of this file. 
  1. ACHS3PP2 ; IHS/ITSC/PMF - PRINT CHS THIRD PARTY PAYMENT REPORT - INDIVIDUAL PAT ;    [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1.  ;TPF THIS IS A REWRITE OF ACHSPPB
  1.  ;CALLED FROM ACHS3PP1
  1.  ;
  1.  D BRPT^ACHSFU
  1.  ;
  1.  S (ACHSOBL,ACHSOBLS,ACHSOBLT,ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDOCS)=0
  1.  S (ACHSDOCT,ACHSIHSP,ACHSIHSS,ACHSIHST,C,ACHSPAGE,ACHS43ST,ACHS57ST)=0
  1.  S (ACHS64ST,ACHS0ST,ACHS43T,ACHS57T,ACHS64T,ACHS0T)=0
  1.  K ACHSPATP
  1.  ;
  1.  ;BEGIN INDIV. PATIENT LOOP
  1.  S ACHSPAT=""
  1.  F  S ACHSPAT=$O(^TMP("ACHS3PP",$J,ACHSPAT)) Q:ACHSPAT=""  D
  1.  .S ACHSPAGE=0
  1.  .D:'$O(^TMP("ACHS3PP",$J,ACHSPAT,0)) HEADER,NODATA
  1.  .D HEADER
  1.  .D GETPAT
  1.  D TOTL
  1.  Q
  1. GETPAT ;
  1.  ;I '$D(ACHSPAT(0))
  1.  ;
  1.  S ACHSPATP=$S($D(^DPT(ACHSPAT,0)):$P($G(^DPT(ACHSPAT,0)),U),1:"NO NAME")
  1.  S ACHSHRN=$S($D(^AUPNPAT(ACHSPAT,41,DUZ(2),0)):$P($G(^AUPNPAT(ACHSPAT,41,DUZ(2),0)),U,2),1:"NO HRN") D HEADER1
  1.  D HEADER2
  1.  ;
  1.  S ACHSDOC=0
  1.  F  S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSPAT,ACHSDOC)) Q:ACHSDOC=""  D
  1.  .S Z=$G(^TMP("ACHS3PP",$J,ACHSPAT,ACHSDOC))
  1.  .S D=$P(Z,U,1),ACHSIDT=$E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
  1.  .S S=$P(Z,U,5),ACHSSERV=$S(S=1:"HOSP",S=2:"DENT",S=3:"OUTP",1:"UNKN")
  1.  .S ACHSOBL=$P(Z,U,2),ACHS3PP=$P(Z,U,3),ACHSIHSP=$P(Z,U,4)
  1.  .S C=C+1,ACHSDOCS=C
  1. PDATA .;Print the Data 
  1.  .I ACHSRTYP["D" D DETAIL
  1.  .;
  1.  .I IOST["P-"&($Y>56) D HEADER
  1.  .I IOST["C-",'$D(IO("S")),$Y>24 D HEADER D
  1.  ..I '$$DIR^XBDIR("E") D END Q
  1.  ..D HEADER
  1.  .S ACHSOBLS=ACHSOBLS+ACHSOBL,ACHS3PPS=ACHS3PPS+ACHS3PP,ACHSIHSS=ACHSIHSS+ACHSIHSP
  1.  .I ACHSSER=4 D
  1.  .. S:S=1 ACHS43ST=ACHS43ST+1
  1.  .. S:S=2 ACHS57ST=ACHS57ST+1
  1.  .. S:S=3 ACHS64ST=ACHS64ST+1
  1.  .. I S'=1&(S'=2)&(S'=3) S ACHS0ST=ACHS0ST+1
  1.  .S ACHSFLG=1
  1.  D SUBTOTL
  1.  Q
  1.  ;
  1. DETAIL ;DETAIL LINE
  1.  W !?1,ACHSDOC,?22,ACHSSERV,?30,ACHSIDT,?40
  1.  S X=ACHSOBL,X2=2
  1.  D COMMA^%DTC
  1.  W $J(X,12),?53
  1.  S X=ACHSIHSP,X2=2
  1.  D COMMA^%DTC
  1.  W $J(X,12),?65
  1.  S X=ACHS3PP,X2=2
  1.  D COMMA^%DTC
  1.  W $J(X,11)
  1.  Q
  1. SUBTOTL ;
  1.  W !,$$REPEAT^XLFSTR("-",80),!?1,"SUBTOTAL",?4,$J(ACHSDOCS,4)
  1.  S X=ACHSOBLS,X2="2$"
  1.  D COMMA^%DTC
  1.  W ?40,$J(X,12)
  1.  S X=ACHSIHSS,X2="2$"
  1.  D COMMA^%DTC
  1.  W ?53,$J(X,12)
  1.  S X=ACHS3PPS,X2="2$"
  1.  D COMMA^%DTC
  1.  W ?65,$J(X,12)
  1.  I ACHSOBLS>0&(ACHSIHSS>0) W !! S Z=(ACHSIHSS/ACHSOBLS)*100 W "PERCENTAGES OF PAYMENT TO OBLIGATED",?59,$E(Z,1,5)_"%"
  1.  I ACHSOBLS>0&(ACHS3PPS>0) S X=(ACHS3PPS/ACHSOBLS)*100 W ?71,$E(X,1,5)_"%"
  1.  I ACHSSER=4 W !?5,"*HOSP - ",ACHS43ST,"*",?25,"*DENT - ",ACHS57ST,"*",?45,"*OUTP - ",ACHS64ST,"*",?65,"*UNKN - ",ACHS0ST,"*"
  1.  S ACHS43T=ACHS43T+ACHS43ST,ACHS57T=ACHS57T+ACHS57ST,ACHS64T=ACHS64T+ACHS64ST,ACHS0T=ACHS0T+ACHS0ST
  1.  S ACHSOBLT=ACHSOBLT+ACHSOBLS,ACHSIHST=ACHSIHST+ACHSIHSS,ACHS3PPT=ACHS3PPT+ACHS3PPS,ACHSDOCT=ACHSDOCT+ACHSDOCS
  1.  K DIR
  1.  I IOST["C-",'$D(IO("S")) W !! I '$$DIR^XBDIR("E") D END Q
  1.  S (C,ACHSOBLS,ACHSIHSS,ACHS3PPS,ACHSDOCS,ACHSFLG,ACHS43ST,ACHS57ST,ACHS64ST,ACHS0ST)=0
  1.  Q
  1.  ;
  1. TOTL ;
  1.  W !!!!,$$REPEAT^XLFSTR("=",80),!!?1,"TOTAL",?9,$J(ACHSDOCT,4)
  1.  S X=ACHSOBLT,X2="2$"
  1.  D COMMA^%DTC
  1.  W ?40,$J(X,12)
  1.  S X=ACHSIHST,X2="2$"
  1.  D COMMA^%DTC
  1.  W ?53,$J(X,12)
  1.  S X=ACHS3PPT,X2="2$"
  1.  D COMMA^%DTC
  1.  W ?65,$J(X,12)
  1.  I ACHSOBLT>0&(ACHSIHST>0) W !! S Z=(ACHSIHST/ACHSOBLT)*100 W "PERCENTAGES OF PAYMENT TO OBLIGATED",?59,$E(Z,1,5)_"%"
  1.  I ACHSOBLT>0&(ACHS3PPT>0) S X=(ACHS3PPT/ACHSOBLT)*100 W ?71,$E(X,1,5)_"%"
  1.  I ACHSSER=4 W !?5,"*HOSP - ",ACHS43T,"*",?25,"*DENT - ",ACHS57T,"*",?45,"*OUTP - ",ACHS64T,"*",?65,"*UNKN - ",ACHS0T,"*"
  1.  K DIR
  1.  I IOST["C-",'$D(IO("S")) W !! I '$$DIR^XBDIR("E") D END Q
  1.  Q
  1.  ;
  1. END ;Close device, kill variables, quit
  1.  D ^%ZISC
  1.  S:$D(ZTQUEUED) ZTREQ="@"
  1.  K ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDAT,ACHSDOC,ACHSDOCS,ACHSDOCT
  1.  K ACHSHRN,ACHSIDT,ACHSIHSP,ACHSIHSS,ACHSIHST,ACHSQIO
  1.  K ACHSOBL,ACHSOBLS,ACHSOBLT,ACHSPAT,ACHSSERV,ACHSTIM,ACHSUSR,C,Z,S,D,P
  1.  K ACHSFLG,ACHSOST,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
  1.  K ACHS64ST,ACHS64,ACHSPAGE,DIR,I,X,X2,Y,^TMP("ACHS3PP",$J)
  1.  Q
  1.  ;
  1.  U IO
  1.  W @IOF
  1.  S ACHSPAGE=ACHSPAGE+1
  1.  ;
  1.  S Y=$$HTE^XLFDT($H),ACHSDAT=$P(Y,"@",1),ACHSTIM=$P(Y,"@",2)
  1.  W !,"*",ACHSDAT
  1.  S X=$$LOC^ACHS
  1.  W ?((80/2)-($L(X)/2)),X
  1.  W ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*"
  1.  W !!
  1.  S X="3rd Party Payment Report - Page "
  1.  W ?((80/2)-($L(X)/2)),X_ACHSPAGE
  1.  W !
  1.  S X="For FISCAL YEAR: "
  1.  W ?((80/2)-($L(X)/2)),X_ACHSFY
  1.  W !,$$REPEAT^XLFSTR("*",80)
  1.  Q
  1.  ;
  1. HEADER1 ;
  1.  W !!?5,"PATIENT NAME: ",ACHSPATP,?62,"CHART#: ",ACHSHRN
  1.  Q
  1.  ;
  1. HEADER2 ;
  1.  W !!?1,"DOCUMENT #"
  1.  W:ACHSRTYP["D" ?22,"SERV",?30,"ISSUE DT"
  1.  W ?42,"$ OBLIGD $",?55,"$ IHS PMT $",?69,"$ 3P PMT $"
  1.  Q
  1.  ;
  1. NODATA ;
  1.  S ACHSPATP=$P($G(^DPT(ACHSPAT,0)),U)
  1.  S ACHSPATP=$P(ACHSPATP,",",2)_" "_$P(ACHSPATP,",",1)
  1.  W !!!,"NO DATA FOR SPECIFIED FISCAL YEAR FOR ",ACHSPATP
  1.  K ^TMP("ACHS3PP",$J,ACHSPAT)
  1.  W !!!!
  1.  D:'$$DIR^XBDIR("E") END
  1.  I $D(^TMP("ACHS3PP",$J)) Q
  1.  D:IOST["C-"&'$D(IO("S")) ^ACHS3PP5
  1.  Q
  1.  ;