- ACHS3PPT ; IHS/OIT/FCJ - PRINT THIRD PARTY PAYMENT REPORT ALL PATIENTS BY INS ;
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**16**;JUN 11, 2001
- ;NEW ROUTINE FOR PATCH 16
- ;
- ;
- S ACHSBM=22
- P1 ;
- S ACHSFAC="" F S ACHSFAC=$O(^TMP("ACHS3PP",$J,ACHSFAC)) G:ACHSFAC="" TOTL D Q:$D(DUOUT)
- .S ACHSINS="",ACHSPAGE=0,ACHSFLG1=0 D HEADER
- .F ACHSX="I","U","T" D Q:$D(DUOUT)
- ..S ACHSFLG=1,ACHSDOC="",ACHSFLG1=1
- ..S (ACHSINSP,ACHSINSS,ACHSOBLT,ACHS3PPT,ACHSIHST,ACHSINSX,ACHSDOCT)=0
- ..I ACHSX="T" D P2 Q
- ..F S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSDOC)) Q:ACHSDOC="" D Q:$D(DUOUT)
- ...S ACHSINST=0
- ...S Z=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC))
- ...S Z1=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSDOC))
- ...S ACHSINS=$S(ACHSX="U":"UNIDENTIFIED INSURANCE",1:"IHS ONLY PAY")
- ...S (ACHSINSP,ACHSINST)=^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSDOC)
- ...I ACHSX="I",$P(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC),U,3)>0 Q
- ...D DETAIL D:ACHSRTYP="P" PRT
- ..Q:$D(DUOUT)
- ..S ACHSFLG1=0 D TOT2
- Q
- P2 ;
- S ACHSI="",ACHSINST=0
- F S ACHSI=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSI)) Q:ACHSI'?1N.N D Q:$D(DUOUT)
- .S ACHSDOC="",ACHSINSP="",ACHSFLG1=1,(ACHSDOCT,ACHSOBLT,ACHSIHST,ACHSINSX)=0
- .S ACHSINS=$P(^AUTNINS($P(ACHSI,U),0),U)
- .F S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSI,ACHSDOC)) Q:ACHSDOC="" D Q:$D(DUOUT)
- ..S Z=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC))
- ..S ACHSINSP=^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSI,ACHSDOC)
- ..S ACHSINST=ACHSINST+$P(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSI,ACHSDOC),U)
- ..D DETAIL D:ACHSRTYP="P" PRT
- .Q:$D(DUOUT)
- .S ACHSFLG1=0 D TOT2
- Q
- ;
- DETAIL ;
- 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 ACHSOBL=$P(Z,U,2),ACHS3PP=$P(Z,U,3),ACHSIHSP=$P(Z,U,4)
- S C=C+1,ACHSDOCS=C,ACHSFLG=1,ACHSDOCT=ACHSDOCT+1
- S ACHSOBLS=ACHSOBLS+ACHSOBL,ACHS3PPS=ACHS3PPS+ACHS3PP,ACHSIHSS=ACHSIHSS+ACHSIHSP,ACHSINSS=ACHSINSS+ACHSINST
- S ACHSOBLT=ACHSOBLT+ACHSOBL,ACHS3PPT=ACHS3PPT+ACHS3PP,ACHSIHST=ACHSIHST+ACHSIHSP,ACHSINSX=ACHSINSX+ACHSINSP
- I ACHSSER=4 D
- . S:S=1 ACHS43ST=ACHS43ST+1
- . S:S=2 ACHS57ST=ACHS57ST+1
- . S:S=3 ACHS64ST=ACHS64ST+1
- . I S'=1&(S'=2)&(S'=3) S ACHS0ST=ACHS0ST+1
- Q
- PRT ;Prints Data
- W:ACHSFLG1=1 !!,ACHSINS S ACHSFLG1=0
- 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=$S(ACHSX="I":ACHS3PP,1:ACHSINSP),X2=2
- . D COMMA^%DTC
- . W $J(X,12)
- I IOST["P-",$Y>ACHSBM S ACHSFLG=0,ACHSFLG1=1 D HEADER
- I IOST["C-",'$D(IO("S")),$Y>ACHSBM G END:'$$DIR^XBDIR("E") S ACHSFLG=0,ACHSFLG1=1 D HEADER
- Q
- ;
- TOT2 ;
- W:ACHSRTYP="P" !!,$$REPEAT^XLFSTR("-",80)
- W:ACHSRTYP="T" !!,ACHSINS
- W !?1,"TOTAL",?10,$J(ACHSDOCT,4)
- S X=ACHSOBLT,X2="2$"
- D COMMA^%DTC
- W ?40,$J(X,12)
- S X=ACHSIHST,X2="2$"
- D COMMA^%DTC
- W ?55,$J(X,12)
- S X=$S(ACHSX="I":ACHS3PPT,1:ACHSINSX),X2="2$"
- D COMMA^%DTC
- W ?68,$J(X,12)
- K DIR
- I IOST["C-",'$D(IO("S")),$Y>ACHSBM W !! G END:'$$DIR^XBDIR("E") D HEADER
- S ACHSFLG1=0 D:ACHSRTYP="P" HEADER
- Q
- TOTL ;
- W !!,$$REPEAT^XLFSTR("-",80),!?1,"TOTAL",?10,$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")
- 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,ACHSFLG1,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
- K ACHS64ST,ACHS64T,ACHSSER
- K ACHSI,ACHSINS,ACHSINSS,ACHSINST,ACHSRTYP,ACHSX
- 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
- ;
- W !! W:ACHSRTYP["T" "PAYOR"
- W:ACHSRTYP["P" ?1,"DOCUMENT #",?15,"SERV",?23,"ISSUE DT"
- W ?41,"$ OBLIGD $",?55,"$ IHS PMT $",?70,"$ 3P PMT $"
- W:ACHSFLG1=1 !,ACHSINS S ACHSFLG1=0
- Q
- ;
- NODATA ;
- W !!!,"NO DATA FOR SPECIFIED FISCAL YEAR"
- K ^TMP("ACHS3PP",$J)
- I $D(ACHSSERP) W " FOR "_ACHSSERP_" SERVICE(S)" W !!!!
- I IOST["C-",'$D(IO("S")) G:'$$DIR^XBDIR("E") END G ^ACHS3PPQ
- G END
- ;
- ACHS3PPT ; IHS/OIT/FCJ - PRINT THIRD PARTY PAYMENT REPORT ALL PATIENTS BY INS ;
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**16**;JUN 11, 2001
- +2 ;NEW ROUTINE FOR PATCH 16
- +3 ;
- +4 ;
- +5 SET ACHSBM=22
- P1 ;
- +1 SET ACHSFAC=""
- FOR
- SET ACHSFAC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC))
- IF ACHSFAC=""
- GOTO TOTL
- Begin DoDot:1
- +2 SET ACHSINS=""
- SET ACHSPAGE=0
- SET ACHSFLG1=0
- DO HEADER
- +3 FOR ACHSX="I","U","T"
- Begin DoDot:2
- +4 SET ACHSFLG=1
- SET ACHSDOC=""
- SET ACHSFLG1=1
- +5 SET (ACHSINSP,ACHSINSS,ACHSOBLT,ACHS3PPT,ACHSIHST,ACHSINSX,ACHSDOCT)=0
- +6 IF ACHSX="T"
- DO P2
- QUIT
- +7 FOR
- SET ACHSDOC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSDOC))
- IF ACHSDOC=""
- QUIT
- Begin DoDot:3
- +8 SET ACHSINST=0
- +9 SET Z=$GET(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC))
- +10 SET Z1=$GET(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSDOC))
- +11 SET ACHSINS=$SELECT(ACHSX="U":"UNIDENTIFIED INSURANCE",1:"IHS ONLY PAY")
- +12 SET (ACHSINSP,ACHSINST)=^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSDOC)
- +13 IF ACHSX="I"
- IF $PIECE(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC),U,3)>0
- QUIT
- +14 DO DETAIL
- IF ACHSRTYP="P"
- DO PRT
- End DoDot:3
- IF $DATA(DUOUT)
- QUIT
- +15 IF $DATA(DUOUT)
- QUIT
- +16 SET ACHSFLG1=0
- DO TOT2
- End DoDot:2
- IF $DATA(DUOUT)
- QUIT
- End DoDot:1
- IF $DATA(DUOUT)
- QUIT
- +17 QUIT
- P2 ;
- +1 SET ACHSI=""
- SET ACHSINST=0
- +2 FOR
- SET ACHSI=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSI))
- IF ACHSI'?1N.N
- QUIT
- Begin DoDot:1
- +3 SET ACHSDOC=""
- SET ACHSINSP=""
- SET ACHSFLG1=1
- SET (ACHSDOCT,ACHSOBLT,ACHSIHST,ACHSINSX)=0
- +4 SET ACHSINS=$PIECE(^AUTNINS($PIECE(ACHSI,U),0),U)
- +5 FOR
- SET ACHSDOC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSI,ACHSDOC))
- IF ACHSDOC=""
- QUIT
- Begin DoDot:2
- +6 SET Z=$GET(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC))
- +7 SET ACHSINSP=^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSI,ACHSDOC)
- +8 SET ACHSINST=ACHSINST+$PIECE(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSI,ACHSDOC),U)
- +9 DO DETAIL
- IF ACHSRTYP="P"
- DO PRT
- End DoDot:2
- IF $DATA(DUOUT)
- QUIT
- +10 IF $DATA(DUOUT)
- QUIT
- +11 SET ACHSFLG1=0
- DO TOT2
- End DoDot:1
- IF $DATA(DUOUT)
- QUIT
- +12 QUIT
- +13 ;
- DETAIL ;
- +1 SET D=$PIECE(Z,U,1)
- SET ACHSIDT=$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
- +2 SET S=$PIECE(Z,U,5)
- SET ACHSSERV=$SELECT(S=1:"HOSP",S=2:"DENT",S=3:"OUTP",1:"UNKN")
- +3 SET ACHSOBL=$PIECE(Z,U,2)
- SET ACHS3PP=$PIECE(Z,U,3)
- SET ACHSIHSP=$PIECE(Z,U,4)
- +4 SET C=C+1
- SET ACHSDOCS=C
- SET ACHSFLG=1
- SET ACHSDOCT=ACHSDOCT+1
- +5 SET ACHSOBLS=ACHSOBLS+ACHSOBL
- SET ACHS3PPS=ACHS3PPS+ACHS3PP
- SET ACHSIHSS=ACHSIHSS+ACHSIHSP
- SET ACHSINSS=ACHSINSS+ACHSINST
- +6 SET ACHSOBLT=ACHSOBLT+ACHSOBL
- SET ACHS3PPT=ACHS3PPT+ACHS3PP
- SET ACHSIHST=ACHSIHST+ACHSIHSP
- SET ACHSINSX=ACHSINSX+ACHSINSP
- +7 IF ACHSSER=4
- Begin DoDot:1
- +8 IF S=1
- SET ACHS43ST=ACHS43ST+1
- +9 IF S=2
- SET ACHS57ST=ACHS57ST+1
- +10 IF S=3
- SET ACHS64ST=ACHS64ST+1
- +11 IF S'=1&(S'=2)&(S'=3)
- SET ACHS0ST=ACHS0ST+1
- End DoDot:1
- +12 QUIT
- PRT ;Prints Data
- +1 IF ACHSFLG1=1
- WRITE !!,ACHSINS
- SET ACHSFLG1=0
- +2 Begin DoDot:1
- +3 WRITE !?1,ACHSDOC,?15,ACHSSERV,?23,ACHSIDT,?40
- +4 SET X=ACHSOBL
- SET X2=2
- +5 DO COMMA^%DTC
- +6 WRITE $JUSTIFY(X,12),?55
- +7 SET X=ACHSIHSP
- SET X2=2
- +8 DO COMMA^%DTC
- +9 WRITE $JUSTIFY(X,12),?68
- +10 SET X=$SELECT(ACHSX="I":ACHS3PP,1:ACHSINSP)
- SET X2=2
- +11 DO COMMA^%DTC
- +12 WRITE $JUSTIFY(X,12)
- End DoDot:1
- +13 IF IOST["P-"
- IF $Y>ACHSBM
- SET ACHSFLG=0
- SET ACHSFLG1=1
- DO HEADER
- +14 IF IOST["C-"
- IF '$DATA(IO("S"))
- IF $Y>ACHSBM
- IF '$$DIR^XBDIR("E")
- GOTO END
- SET ACHSFLG=0
- SET ACHSFLG1=1
- DO HEADER
- +15 QUIT
- +16 ;
- TOT2 ;
- +1 IF ACHSRTYP="P"
- WRITE !!,$$REPEAT^XLFSTR("-",80)
- +2 IF ACHSRTYP="T"
- WRITE !!,ACHSINS
- +3 WRITE !?1,"TOTAL",?10,$JUSTIFY(ACHSDOCT,4)
- +4 SET X=ACHSOBLT
- SET X2="2$"
- +5 DO COMMA^%DTC
- +6 WRITE ?40,$JUSTIFY(X,12)
- +7 SET X=ACHSIHST
- SET X2="2$"
- +8 DO COMMA^%DTC
- +9 WRITE ?55,$JUSTIFY(X,12)
- +10 SET X=$SELECT(ACHSX="I":ACHS3PPT,1:ACHSINSX)
- SET X2="2$"
- +11 DO COMMA^%DTC
- +12 WRITE ?68,$JUSTIFY(X,12)
- +13 KILL DIR
- +14 IF IOST["C-"
- IF '$DATA(IO("S"))
- IF $Y>ACHSBM
- WRITE !!
- IF '$$DIR^XBDIR("E")
- GOTO END
- DO HEADER
- +15 SET ACHSFLG1=0
- IF ACHSRTYP="P"
- DO HEADER
- +16 QUIT
- TOTL ;
- +1 WRITE !!,$$REPEAT^XLFSTR("-",80),!?1,"TOTAL",?10,$JUSTIFY(ACHSDOCS,4)
- +2 SET X=ACHSOBLS
- SET X2="2$"
- +3 DO COMMA^%DTC
- +4 WRITE ?40,$JUSTIFY(X,12)
- +5 SET X=ACHSIHSS
- SET X2="2$"
- +6 DO COMMA^%DTC
- +7 WRITE ?55,$JUSTIFY(X,12)
- +8 SET X=ACHS3PPS
- SET X2="2$"
- +9 DO COMMA^%DTC
- +10 WRITE ?68,$JUSTIFY(X,12)
- +11 IF ACHSOBLS>0&(ACHSIHSS>0)
- WRITE !!
- SET Z=(ACHSIHSS/ACHSOBLS)*100
- WRITE "PERCENTAGE OF PAYMENT TO OBLIGATED",?61,$EXTRACT(Z,1,5)_"%"
- +12 IF ACHSOBLS>0&(ACHS3PPS>0)
- SET X=(ACHS3PPS/ACHSOBLS)*100
- WRITE ?74,$EXTRACT(X,1,5)_"%"
- +13 IF ACHSSER=4
- WRITE !?5,"*HOSP - ",ACHS43ST,"*",?25,"*DENT - ",ACHS57ST,"*",?45,"*OUTP - ",ACHS64ST,"*",?65,"*UNKN - ",ACHS0ST,"*"
- +14 KILL DIR
- +15 IF IOST["C-"
- IF '$DATA(IO("S"))
- WRITE !!
- IF '$$DIR^XBDIR("E")
- GOTO END
- END ;Close device, kill variables, quit
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 DO ^%ZISC
- +3 KILL ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDAT,ACHSDOC,ACHSDOCS,ACHSDOCT
- +4 KILL ACHSHRN,ACHSIDT,ACHSIHSP,ACHSIHSS,ACHSIHST,ACHSQIO,ACHS0ST
- +5 KILL ACHSOBL,ACHSOBLS,ACHSOBLT,ACHSPAT,ACHSSERP,ACHSSERV,ACHSTIM,ACHSUSR,C,Z,S,D,P
- +6 KILL ACHSFLG,ACHSFLG1,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
- +7 KILL ACHS64ST,ACHS64T,ACHSSER
- +8 KILL ACHSI,ACHSINS,ACHSINSS,ACHSINST,ACHSRTYP,ACHSX
- +9 KILL ^TMP("ACHS3PP",$JOB)
- +10 QUIT
- +11 ;
- +1 USE IO
- +2 WRITE @IOF
- +3 SET ACHSPAGE=ACHSPAGE+1
- +4 SET Y=$$HTE^XLFDT($HOROLOG)
- SET ACHSDAT=$PIECE(Y,"@",1)
- SET ACHSTIM=$PIECE(Y,"@",2)
- +5 WRITE !,"*",ACHSDAT
- +6 SET X=$$LOC^ACHS
- +7 WRITE ?((80/2)-($LENGTH(X)/2)),X
- +8 WRITE ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*"
- +9 WRITE !!
- +10 SET X="3rd Party Payment Report - Page "
- +11 WRITE ?((80/2)-($LENGTH(X)/2)),X_ACHSPAGE
- +12 WRITE !
- +13 SET X="For FISCAL YEAR: "
- +14 WRITE ?((80/2)-($LENGTH(X)/2)),X_ACHSFY
- +15 WRITE !
- +16 IF ACHSSER'=4
- SET ACHSSERP=$SELECT(ACHSSER=1:"HOSPITAL",ACHSSER=2:"DENTAL",ACHSSER=3:"OUTPATIENT",1:"UNKNOWN")
- WRITE ?33,"SERVICE: "_ACHSSERP
- WRITE !
- +17 WRITE $$REPEAT^XLFSTR("*",80)
- +18 SET ACHSFLG=0
- +19 ;
- +1 WRITE !!
- IF ACHSRTYP["T"
- WRITE "PAYOR"
- +2 IF ACHSRTYP["P"
- WRITE ?1,"DOCUMENT #",?15,"SERV",?23,"ISSUE DT"
- +3 WRITE ?41,"$ OBLIGD $",?55,"$ IHS PMT $",?70,"$ 3P PMT $"
- +4 IF ACHSFLG1=1
- WRITE !,ACHSINS
- SET ACHSFLG1=0
- +5 QUIT
- +6 ;
- NODATA ;
- +1 WRITE !!!,"NO DATA FOR SPECIFIED FISCAL YEAR"
- +2 KILL ^TMP("ACHS3PP",$JOB)
- +3 IF $DATA(ACHSSERP)
- WRITE " FOR "_ACHSSERP_" SERVICE(S)"
- WRITE !!!!
- +4 IF IOST["C-"
- IF '$DATA(IO("S"))
- IF '$$DIR^XBDIR("E")
- GOTO END
- GOTO ^ACHS3PPQ
- +5 GOTO END
- +6 ;
