ACHS3PP3 ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT (ALL PATIENTS) ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
;TPF RE-WRITTEN FROM ACHS3PPC
;
;
I $D(ACHSPAT) D ^ACHS3PP1 Q
S ACHSFAC=DUZ(2)
GETFY ;
S ACHSFY1=""
F S ACHSFY1=$O(^ACHSF(ACHSFAC,"D","B",ACHSFY1)) Q:ACHSFY1="" D
.I '$D(^TMP("ACHS3PP",$J,ACHSFAC)) S ^TMP("ACHS3PP",$J,ACHSFAC,0)=""
.S ACHSFYA=$E(ACHSFY1,2),ACHSFYB=$E(ACHSFY,4)
.I ACHSFYA'=ACHSFYB Q
.D GETDIEN
K ACHSDOCR,X,Y,Z
D ^ACHS3PP4 ;DO ALL PATIENTS
Q
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"))
.I $P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,9)'>0 Q
.S ACHSDOCR=$G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))
.Q:ACHSDOCR=""
.S ACHSSERV=$S($P(ACHSDOCR,U,4):$P(ACHSDOCR,U,4),1:"UNKN")
.I '(ACHSSER=4),ACHSSERV'=ACHSSER Q
.D GETIDT
Q
GETIDT ;GET TRANSACTION RECORD INFORMATION
S ACHSIDT=$P(ACHSDOCR,U,2),ACHSOBL=$P(ACHSDOCR,U,9)
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)
.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)
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,ACHSFAC,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV
Q
;
ACHS3PP3 ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT (ALL PATIENTS) ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 ;TPF RE-WRITTEN FROM ACHS3PPC
+4 ;
+5 ;
+6 IF $DATA(ACHSPAT)
DO ^ACHS3PP1
QUIT
+7 SET ACHSFAC=DUZ(2)
GETFY ;
+1 SET ACHSFY1=""
+2 FOR
SET ACHSFY1=$ORDER(^ACHSF(ACHSFAC,"D","B",ACHSFY1))
IF ACHSFY1=""
QUIT
Begin DoDot:1
+3 IF '$DATA(^TMP("ACHS3PP",$JOB,ACHSFAC))
SET ^TMP("ACHS3PP",$JOB,ACHSFAC,0)=""
+4 SET ACHSFYA=$EXTRACT(ACHSFY1,2)
SET ACHSFYB=$EXTRACT(ACHSFY,4)
+5 IF ACHSFYA'=ACHSFYB
QUIT
+6 DO GETDIEN
End DoDot:1
+7 KILL ACHSDOCR,X,Y,Z
+8 ;DO ALL PATIENTS
DO ^ACHS3PP4
+9 QUIT
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 IF $PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,9)'>0
QUIT
+5 SET ACHSDOCR=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))
+6 IF ACHSDOCR=""
QUIT
+7 SET ACHSSERV=$SELECT($PIECE(ACHSDOCR,U,4):$PIECE(ACHSDOCR,U,4),1:"UNKN")
+8 IF '(ACHSSER=4)
IF ACHSSERV'=ACHSSER
QUIT
+9 DO GETIDT
End DoDot:1
+10 QUIT
GETIDT ;GET TRANSACTION RECORD INFORMATION
+1 SET ACHSIDT=$PIECE(ACHSDOCR,U,2)
SET ACHSOBL=$PIECE(ACHSDOCR,U,9)
+2 KILL Z
+3 ;
+4 SET ACHSTRAN=0
+5 FOR
SET ACHSTRAN=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHSTRAN))
IF 'ACHSTRAN
QUIT
Begin DoDot:1
+6 SET X=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHSTRAN,0))
IF X=""
QUIT
+7 SET Y=$PIECE(X,U,2)
+8 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)
End DoDot:1
+9 IF '$DATA(Z)
QUIT
+10 IF $PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,4)'=""
SET ACHSAREA=$PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,4)
+11 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)
+12 SET ^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV
+13 QUIT
+14 ;
