ACHS3PPC ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT (ALL PATIENTS) ; [ 04/17/2002 1:56 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,16**;JUN 11, 2001
;ACHS*3.1*4 repair quit statement
;ACHS*3.1*16 IHS.OIT.FCJ Added amount for insurers
;
I '$D(ACHSPAT(0)) G ^ACHS3PPA ;THIRD PARTY PAYMENT REPORT
;
S ACHSFAC=DUZ(2),ACHSFY1=""
GETFY ;
S ACHSFY1=$O(^ACHSF(ACHSFAC,"D","B",ACHSFY1))
I ACHSFY1="",'$D(^TMP("ACHS3PP",$J,ACHSFAC)) S ^TMP("ACHS3PP",$J,ACHSFAC,0)=""
;
I ACHSFY1="" K ACHSDOCR,X,Y,Z G ^ACHS3PPP ;PRINT THIRD PARTY PAYMENT REPORT (ALL PATS)
;
S ACHSFYA=$E(ACHSFY1,2),ACHSFYB=$E(ACHSFY,4)
I ACHSFYA'=ACHSFYB G GETFY
;
D GETDIEN
G GETFY
Q
;
;MAIN LOOP
GETDIEN ;
S ACHSDIEN=""
F S ACHSDIEN=$O(^ACHSF(ACHSFAC,"D","B",ACHSFY1,ACHSDIEN)) Q:ACHSDIEN="" D
.Q:'$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))!'$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"))
.;
.;SKIP IF 'TOTAL AMOUNT OBLIGATED' ?????WHAT ABOUT NEGATIVES?????
.Q:$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,9)'>0
.S ACHSDOCR=$G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)) ;GET DOCUMENT 0 NODE
.;
.;GET 'TYPE OF SERVICE'
.S ACHSSERV=$S($P(ACHSDOCR,U,4):$P(ACHSDOCR,U,4),1:"UNKN")
.;
.;ACHSSER=4 MEANS ALL TYPES
.Q:'(ACHSSER=4)&(ACHSSERV'=ACHSSER)
.D GETIDT
Q
;
GETIDT ;
S ACHSIDT=$P(ACHSDOCR,U,2) ;'ORDER DATE'
S ACHSOBL=$P(ACHSDOCR,U,9) ;'TOTAL OBLIGATED AMOUNT'
K Z
;
;GO THROUGH TRANSACTIONS
F %=0:0 S %=$O(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%)) Q:'% D
.S X=$G(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%,0))
.;
.S Y=$P(X,U,2) ;'TRANSACTION TYPE'
.;
.;IF 'TRANSACTION TYPE' IS NOT "INITIAL" AND NOT "CANCEL"
.I Y'="I",Y'="C" D
..S Z("I")=$G(Z("I"))+$P(X,U,4) ;ADD IN 'IHS PAYMENT AMOUNT'
..S Z("3")=$G(Z("3"))+$P(X,U,8) ;ADD IN 'THIRD PARTY PAY AMT'
..;ACHS*3.1*16 IHS.OIT.FCJ ADDED NXT SECTION FOR DETAIL TP INSURER
..I (ACHSRTYP="T")!(ACHSRTYP="P") D
...I $P(X,U,12)="",$P(X,U,8)>0 S:'$D(Z("TP","U")) Z("TP","U")=0 S Z("TP","U")=Z("TP","U")+$P(X,U,8) Q ;UNIDENTIFIED INSURANCE
...I $P(X,U,12)="",$P(X,U,8)<1 S:'$D(Z("TP","I")) Z("TP","I")=0 S Z("TP","I")=Z("TP","I")+$P(X,U,4) Q ;IHS PAY DOCUMENTS
...I '$D(Z("T",$P(X,U,12))) S Z("T",$P(X,U,12))=$P(X,U,8)
...E S Z("T",$P(X,U,12))=Z("T",$P(X,U,12))+$P(X,U,8)
;
;ACHS*3.1*4 3/26/02 pmf just wanna quit Q:'$D(Z) GETDIEN
I '$D(Z) Q ; ACHS*3.1*4```````1=($G(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$E($P($G(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_$P(ACHSDOCR,U)
;
;GET 'FISCAL YEAR' _ 'PREFIX/REGION' _ 'FINANCIAL LOCATION CODE' _
;'ORDER NUMBER'
S ACHSDOC=$P(ACHSDOCR,U,14)_"-"_$P($G(^AUTTAREA($P($G(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$E($P($G(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_$P(ACHSDOCR,U)
;
S ^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV
;ACHS*3.1*16 IHS.OIT.FCJ ADDED 3 NXT LINES
I (ACHSRTYP="T")!(ACHSRTYP="P") D
.F X="I","U" S:$D(Z("TP",X)) ^TMP("ACHS3PP",$J,ACHSFAC,X,ACHSDOC)=Z("TP",X)
.S X="" F S X=$O(Z("T",X)) Q:X="" S ^TMP("ACHS3PP",$J,ACHSFAC,"T",X,ACHSDOC)=Z("T",X)
Q
;
ACHS3PPC ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT (ALL PATIENTS) ; [ 04/17/2002 1:56 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,16**;JUN 11, 2001
+2 ;ACHS*3.1*4 repair quit statement
+3 ;ACHS*3.1*16 IHS.OIT.FCJ Added amount for insurers
+4 ;
+5 ;THIRD PARTY PAYMENT REPORT
IF '$DATA(ACHSPAT(0))
GOTO ^ACHS3PPA
+6 ;
+7 SET ACHSFAC=DUZ(2)
SET ACHSFY1=""
GETFY ;
+1 SET ACHSFY1=$ORDER(^ACHSF(ACHSFAC,"D","B",ACHSFY1))
+2 IF ACHSFY1=""
IF '$DATA(^TMP("ACHS3PP",$JOB,ACHSFAC))
SET ^TMP("ACHS3PP",$JOB,ACHSFAC,0)=""
+3 ;
+4 ;PRINT THIRD PARTY PAYMENT REPORT (ALL PATS)
IF ACHSFY1=""
KILL ACHSDOCR,X,Y,Z
GOTO ^ACHS3PPP
+5 ;
+6 SET ACHSFYA=$EXTRACT(ACHSFY1,2)
SET ACHSFYB=$EXTRACT(ACHSFY,4)
+7 IF ACHSFYA'=ACHSFYB
GOTO GETFY
+8 ;
+9 DO GETDIEN
+10 GOTO GETFY
+11 QUIT
+12 ;
+13 ;MAIN LOOP
GETDIEN ;
+1 SET ACHSDIEN=""
+2 FOR
SET ACHSDIEN=$ORDER(^ACHSF(ACHSFAC,"D","B",ACHSFY1,ACHSDIEN))
IF ACHSDIEN=""
QUIT
Begin DoDot:1
+3 IF '$DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))!'$DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"))
QUIT
+4 ;
+5 ;SKIP IF 'TOTAL AMOUNT OBLIGATED' ?????WHAT ABOUT NEGATIVES?????
+6 IF $PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,9)'>0
QUIT
+7 ;GET DOCUMENT 0 NODE
SET ACHSDOCR=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))
+8 ;
+9 ;GET 'TYPE OF SERVICE'
+10 SET ACHSSERV=$SELECT($PIECE(ACHSDOCR,U,4):$PIECE(ACHSDOCR,U,4),1:"UNKN")
+11 ;
+12 ;ACHSSER=4 MEANS ALL TYPES
+13 IF '(ACHSSER=4)&(ACHSSERV'=ACHSSER)
QUIT
+14 DO GETIDT
End DoDot:1
+15 QUIT
+16 ;
GETIDT ;
+1 ;'ORDER DATE'
SET ACHSIDT=$PIECE(ACHSDOCR,U,2)
+2 ;'TOTAL OBLIGATED AMOUNT'
SET ACHSOBL=$PIECE(ACHSDOCR,U,9)
+3 KILL Z
+4 ;
+5 ;GO THROUGH TRANSACTIONS
+6 FOR %=0:0
SET %=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%))
IF '%
QUIT
Begin DoDot:1
+7 SET X=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%,0))
+8 ;
+9 ;'TRANSACTION TYPE'
SET Y=$PIECE(X,U,2)
+10 ;
+11 ;IF 'TRANSACTION TYPE' IS NOT "INITIAL" AND NOT "CANCEL"
+12 IF Y'="I"
IF Y'="C"
Begin DoDot:2
+13 ;ADD IN 'IHS PAYMENT AMOUNT'
SET Z("I")=$GET(Z("I"))+$PIECE(X,U,4)
+14 ;ADD IN 'THIRD PARTY PAY AMT'
SET Z("3")=$GET(Z("3"))+$PIECE(X,U,8)
+15 ;ACHS*3.1*16 IHS.OIT.FCJ ADDED NXT SECTION FOR DETAIL TP INSURER
+16 IF (ACHSRTYP="T")!(ACHSRTYP="P")
Begin DoDot:3
+17 ;UNIDENTIFIED INSURANCE
IF $PIECE(X,U,12)=""
IF $PIECE(X,U,8)>0
IF '$DATA(Z("TP","U"))
SET Z("TP","U")=0
SET Z("TP","U")=Z("TP","U")+$PIECE(X,U,8)
QUIT
+18 ;IHS PAY DOCUMENTS
IF $PIECE(X,U,12)=""
IF $PIECE(X,U,8)<1
IF '$DATA(Z("TP","I"))
SET Z("TP","I")=0
SET Z("TP","I")=Z("TP","I")+$PIECE(X,U,4)
QUIT
+19 IF '$DATA(Z("T",$PIECE(X,U,12)))
SET Z("T",$PIECE(X,U,12))=$PIECE(X,U,8)
+20 IF '$TEST
SET Z("T",$PIECE(X,U,12))=Z("T",$PIECE(X,U,12))+$PIECE(X,U,8)
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 ;ACHS*3.1*4 3/26/02 pmf just wanna quit Q:'$D(Z) GETDIEN
+23 ; ACHS*3.1*4```````1=($G(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$E($P($G(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_$P(ACHSDOCR,U)
IF '$DATA(Z)
QUIT
+24 ;
+25 ;GET 'FISCAL YEAR' _ 'PREFIX/REGION' _ 'FINANCIAL LOCATION CODE' _
+26 ;'ORDER NUMBER'
+27 SET ACHSDOC=$PIECE(ACHSDOCR,U,14)_"-"_$PIECE($GET(^AUTTAREA($PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$EXTRACT($PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_$PIECE(ACHSDOCR,U)
+28 ;
+29 SET ^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV
+30 ;ACHS*3.1*16 IHS.OIT.FCJ ADDED 3 NXT LINES
+31 IF (ACHSRTYP="T")!(ACHSRTYP="P")
Begin DoDot:1
+32 FOR X="I","U"
IF $DATA(Z("TP",X))
SET ^TMP("ACHS3PP",$JOB,ACHSFAC,X,ACHSDOC)=Z("TP",X)
+33 SET X=""
FOR
SET X=$ORDER(Z("T",X))
IF X=""
QUIT
SET ^TMP("ACHS3PP",$JOB,ACHSFAC,"T",X,ACHSDOC)=Z("T",X)
End DoDot:1
+34 QUIT
+35 ;
