ACHS3PP1 ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT REPORT - INDIVIDUAL PAT ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
;
;TPF ;THIS IS A REWRITE OF ACHSPPA
;
GETPAT ;
S ACHSFAC=DUZ(2),ACHSPAT=""
F S ACHSPAT=$O(ACHSPAT(ACHSPAT)) Q:ACHSPAT="" D
.I '$D(^ACHSF("AC",ACHSPAT)) S ^TMP("ACHS3PP",$J,ACHSPAT,0)="" Q
.D GETDIEN
K ACHSDOCR,X,Y,Z
;
D ^ACHS3PP2 ;GO LOOP THRU IND. PAT ^TMP GLOBAL CREATED HERE
Q
;
GETDIEN ;
S ACHSDIEN=""
F S ACHSDIEN=$O(^ACHSF("AC",ACHSPAT,ACHSFAC,ACHSDIEN)) Q:ACHSDIEN="" D
.I '$D(^TMP("ACHS3PP",$J,ACHSPAT)) S ^TMP("ACHS3PP",$J,ACHSPAT,0)=""
.Q:'$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))!'$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"))
.S ACHSDOCR=$G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))
.Q:ACHSDOCR=""!($P(ACHSDOCR,U,9)'>0) ;IGNORE 0 TOTAL AMOUNT OBLIGATED
.D GETFY
Q
;
GETFY ;
S ACHSFY1=$P(ACHSDOCR,U,14)
I ACHSFY1="",'$D(^TMP("ACHS3PP",$J,ACHSPAT)) S ^TMP("ACHS3PP",$J,ACHSPAT,0)=""
Q:ACHSFY1=""
Q:ACHSFY1'=$E(ACHSFY,4)
S ACHSSERV=$P(ACHSDOCR,U,4)
Q:'(ACHSSER=4)&(ACHSSERV'=ACHSSER)
GETIDT ;GET TRANSACTION RECORD INFORMATION
S ACHSIDT=$P(ACHSDOCR,U,2)
S ACHSOBL=$P(ACHSDOCR,U,9)
S ACHSHRN=$P(ACHSDOCR,U,21)
K Z
S ACHSTRAN=0
F S ACHSTRAN=$O(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHSTRAN)) Q:'ACHSTRAN D
.S X=$G(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHSTRAN,0)) Q:X=""
.S Y=$P(X,U,2) ;GET TRANSACTION TYPE
.;IGNORE INITIAL AND CANCELLATION TYPES
.I Y'="I",Y'="C" S Z("I")=$G(Z("I"))+$P(X,U,4),Z("3")=$G(Z("3"))+$P(X,U,8)
.Q:'$D(Z) ;QUIT IF NO PAYMENT OR THIRD PARTY PAYMENT AMOUNTS
;
S:$P($G(^AUTTLOC(ACHSFAC,0)),U,4)'="" ACHSAREA=$P($G(^AUTTLOC(ACHSFAC,0)),U,4)
S ACHSDOC=$P(ACHSDOCR,U,14)_"-"_$P($G(^AUTTAREA(ACHSAREA,0)),U,3)_$E($P($G(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_$P(ACHSDOCR,U)
S ^TMP("ACHS3PP",$J,ACHSPAT,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV_U_ACHSHRN
Q
;
ACHS3PP1 ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT REPORT - INDIVIDUAL PAT ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 ;
+4 ;TPF ;THIS IS A REWRITE OF ACHSPPA
+5 ;
GETPAT ;
+1 SET ACHSFAC=DUZ(2)
SET ACHSPAT=""
+2 FOR
SET ACHSPAT=$ORDER(ACHSPAT(ACHSPAT))
IF ACHSPAT=""
QUIT
Begin DoDot:1
+3 IF '$DATA(^ACHSF("AC",ACHSPAT))
SET ^TMP("ACHS3PP",$JOB,ACHSPAT,0)=""
QUIT
+4 DO GETDIEN
End DoDot:1
+5 KILL ACHSDOCR,X,Y,Z
+6 ;
+7 ;GO LOOP THRU IND. PAT ^TMP GLOBAL CREATED HERE
DO ^ACHS3PP2
+8 QUIT
+9 ;
GETDIEN ;
+1 SET ACHSDIEN=""
+2 FOR
SET ACHSDIEN=$ORDER(^ACHSF("AC",ACHSPAT,ACHSFAC,ACHSDIEN))
IF ACHSDIEN=""
QUIT
Begin DoDot:1
+3 IF '$DATA(^TMP("ACHS3PP",$JOB,ACHSPAT))
SET ^TMP("ACHS3PP",$JOB,ACHSPAT,0)=""
+4 IF '$DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))!'$DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"))
QUIT
+5 SET ACHSDOCR=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))
+6 ;IGNORE 0 TOTAL AMOUNT OBLIGATED
IF ACHSDOCR=""!($PIECE(ACHSDOCR,U,9)'>0)
QUIT
+7 DO GETFY
End DoDot:1
+8 QUIT
+9 ;
GETFY ;
+1 SET ACHSFY1=$PIECE(ACHSDOCR,U,14)
+2 IF ACHSFY1=""
IF '$DATA(^TMP("ACHS3PP",$JOB,ACHSPAT))
SET ^TMP("ACHS3PP",$JOB,ACHSPAT,0)=""
+3 IF ACHSFY1=""
QUIT
+4 IF ACHSFY1'=$EXTRACT(ACHSFY,4)
QUIT
+5 SET ACHSSERV=$PIECE(ACHSDOCR,U,4)
+6 IF '(ACHSSER=4)&(ACHSSERV'=ACHSSER)
QUIT
GETIDT ;GET TRANSACTION RECORD INFORMATION
+1 SET ACHSIDT=$PIECE(ACHSDOCR,U,2)
+2 SET ACHSOBL=$PIECE(ACHSDOCR,U,9)
+3 SET ACHSHRN=$PIECE(ACHSDOCR,U,21)
+4 KILL Z
+5 SET ACHSTRAN=0
+6 FOR
SET ACHSTRAN=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHSTRAN))
IF 'ACHSTRAN
QUIT
Begin DoDot:1
+7 SET X=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHSTRAN,0))
IF X=""
QUIT
+8 ;GET TRANSACTION TYPE
SET Y=$PIECE(X,U,2)
+9 ;IGNORE INITIAL AND CANCELLATION TYPES
+10 IF Y'="I"
IF Y'="C"
SET Z("I")=$GET(Z("I"))+$PIECE(X,U,4)
SET Z("3")=$GET(Z("3"))+$PIECE(X,U,8)
+11 ;QUIT IF NO PAYMENT OR THIRD PARTY PAYMENT AMOUNTS
IF '$DATA(Z)
QUIT
End DoDot:1
+12 ;
+13 IF $PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,4)'=""
SET ACHSAREA=$PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,4)
+14 SET ACHSDOC=$PIECE(ACHSDOCR,U,14)_"-"_$PIECE($GET(^AUTTAREA(ACHSAREA,0)),U,3)_$EXTRACT($PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_$PIECE(ACHSDOCR,U)
+15 SET ^TMP("ACHS3PP",$JOB,ACHSPAT,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV_U_ACHSHRN
+16 QUIT
+17 ;
