- 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 ;
