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

ACHS3PP4.m

Go to the documentation of this file.
ACHS3PP4 ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT  [ 10/16/2001   8:16 AM ]
 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
 ;
 ;TPF COPIED AND RE-WRITTEN FROM ACHS3PPP
 ;
 D BRPT^ACHSFU
 I $O(^TMP("ACHS3PP",$J,ACHSFAC,0))="" S ACHSPAGE=0 D HEADER,NODATA Q
 S (ACHSOBL,ACHSOBLS,ACHSOBLT,ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDOCS)=0
 S (ACHSDOCT,ACHSIHSP,ACHSIHSS,ACHSIHST,C,ACHSPAGE,ACHS43ST,ACHS57ST)=0
 S (ACHS64ST,ACHS0ST,ACHS43T,ACHS57T,ACHS64T,ACHS0T)=0
 N OK S OK=1
 ;
 S ACHSFAC=""
 F  S ACHSFAC=$O(^TMP("ACHS3PP",$J,ACHSFAC)) Q:ACHSFAC=""  D P2 I 'OK Q
 I 'OK D END Q
 D TOTL
 Q
 ;
P2 ;
 S ACHSDOC="",ACHSPAGE=0 D HEADER
 ;
 F  S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC)) Q:ACHSDOC=""  D  Q:'OK
 .S Z=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC))
 .Q:Z=""
 .;
 .I $D(ACHSPAT) S P=$S($P(Z,U,7):$P(Z,U,7),1:"NO NAME") S:$D(^DPT(P,0)) ACHSPAT=$P($G(^DPT(P,0)),U,1) S ACHSHRN=$S($P(Z,U,8):$P(Z,U,8),1:"NO HRN") D PATHEAD
 . I ACHSFLG=0 D HEADER1
 . D GETIDT
 Q
 ;
GETIDT ;
 S D=$P(Z,U,1),ACHSIDT=$E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
 S S=$P(Z,U,5),ACHSSERV=$S(S=1:"HOSP",S=2:"DENT",S=3:"OUTP",1:"UNKN")
 S S(S)=""
 S ACHSOBL=$P(Z,U,2),ACHS3PP=$P(Z,U,3),ACHSIHSP=$P(Z,U,4)
 S C=C+1,ACHSDOCS=C,ACHSFLG=1
 ;Prints Data 
 I ACHSRTYP["D" D
 . W !?1,ACHSDOC,?15,ACHSSERV,?23,ACHSIDT,?40
 . S X=ACHSOBL,X2=2
 . D COMMA^%DTC
 . W $J(X,12),?55
 . S X=ACHSIHSP,X2=2
 . D COMMA^%DTC
 . W $J(X,12),?68
 . S X=ACHS3PP,X2=2
 . D COMMA^%DTC
 . W $J(X,12)
 . Q
 I IOST["P-",$Y>ACHSBM S ACHSFLG=0 D HEADER
 I IOST["C-",'$D(IO("S")),$Y>ACHSBM D  Q:'OK
 . S OK=$$DIR^XBDIR("E")
 . I 'OK Q
 . S ACHSFLG=0 D HEADER
 . Q
 ;
 S ACHSOBLS=ACHSOBLS+ACHSOBL,ACHS3PPS=ACHS3PPS+ACHS3PP,ACHSIHSS=ACHSIHSS+ACHSIHSP
 I ACHSSER=4 D
 . I S=1 S ACHS43ST=ACHS43ST+1 Q
 . I S=2 S ACHS57ST=ACHS57ST+1 Q
 . I S=3 S ACHS64ST=ACHS64ST+1 Q
 . ;I S'=1&(S'=2)&(S'=3) S ACHS0ST=ACHS0ST+1
 . S ACHS0ST=ACHS0ST+1
 Q
 ;
TOTL ;
 W !!,$$REPEAT^XLFSTR("-",80),!?1,"TOTAL",?4,$J(ACHSDOCS,4)
 S X=ACHSOBLS,X2="2$"
 D COMMA^%DTC
 W ?40,$J(X,12)
 S X=ACHSIHSS,X2="2$"
 D COMMA^%DTC
 W ?55,$J(X,12)
 S X=ACHS3PPS,X2="2$"
 D COMMA^%DTC
 W ?68,$J(X,12)
 I ACHSOBLS>0&(ACHSIHSS>0) W !! S Z=(ACHSIHSS/ACHSOBLS)*100 W "PERCENTAGE OF PAYMENT TO OBLIGATED",?61,$E(Z,1,5)_"%"
 I ACHSOBLS>0&(ACHS3PPS>0) S X=(ACHS3PPS/ACHSOBLS)*100 W ?74,$E(X,1,5)_"%"
 I ACHSSER=4 W !?5,"*HOSP - ",ACHS43ST,"*",?25,"*DENT - ",ACHS57ST,"*",?45,"*OUTP - ",ACHS64ST,"*",?65,"*UNKN - ",ACHS0ST,"*"
 K DIR
 I IOST["C-",'$D(IO("S")) W !! G END:'$$DIR^XBDIR("E")
 Q
END ;Close device, kill variables, quit
 S:$D(ZTQUEUED) ZTREQ="@"
 D ^%ZISC
 K ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDAT,ACHSDOC,ACHSDOCS,ACHSDOCT
 K ACHSHRN,ACHSIDT,ACHSIHSP,ACHSIHSS,ACHSIHST,ACHSQIO,ACHS0ST
 K ACHSOBL,ACHSOBLS,ACHSOBLT,ACHSPAT,ACHSSERP,ACHSSERV,ACHSTIM,ACHSUSR,C,Z,S,D,P
 K ACHSFLG,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
 K ACHS64ST,ACHS64T,ACHSSER
 K ^TMP("ACHS3PP",$J)
 Q
 ;
 U IO
 W @IOF
 S ACHSPAGE=ACHSPAGE+1
 S Y=$$HTE^XLFDT($H),ACHSDAT=$P(Y,"@",1),ACHSTIM=$P(Y,"@",2)
 W !,"*",ACHSDAT
 S X=$$LOC^ACHS
 W ?((80/2)-($L(X)/2)),X
 W ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*"
 W !!
 S X="3rd Party Payment Report - Page "
 W ?((80/2)-($L(X)/2)),X_ACHSPAGE
 W !
 S X="For FISCAL YEAR: "
 W ?((80/2)-($L(X)/2)),X_ACHSFY
 W !
 I ACHSSER'=4 S ACHSSERP=$S(ACHSSER=1:"HOSPITAL",ACHSSER=2:"DENTAL",ACHSSER=3:"OUTPATIENT",1:"UNKNOWN") W ?33,"SERVICE: "_ACHSSERP W !
 W $$REPEAT^XLFSTR("*",80)
 S ACHSFLG=0
 Q
 ;
HEADER1 ;
 W !!?1,"# DOCS #"
 W:ACHSRTYP["D" ?15,"SERV",?23,"ISSUE DT"
 W ?41,"$ OBLIGD $",?55,"$ IHS PMT $",?70,"$ 3P PMT $",!
 Q
 ;
PATHEAD ;
 W !!?1,"Patient: ",$G(ACHSPAT),"      Chart #: ",$G(ACHSHRN)
 Q
 ;
NODATA ;
 W !!!,"NO DATA FOR SPECIFIED FISCAL YEAR"
 K ^TMP("ACHS3PP",$J)
 I $D(ACHSSERP) W " FOR "_$G(ACHSSERP)_" SERVICE(S)" W !!!!
 I IOST["C-",'$D(IO("S")) D
 .I '$$DIR^XBDIR("E") D END Q
 .D ^ACHS3PP5
 D END
 Q
 ;