ACHS3PPA.m

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

 ;

 S ACHSFAC=DUZ(2),ACHSPAT=0

GETPAT ;

 F  S ACHSPAT=$O(ACHSPAT(ACHSPAT)) Q:ACHSPAT=""  D

 .;PATIENT X-REF

 .I '$D(^ACHSF("AC",ACHSPAT)) S ^TMP("ACHS3PP",$J,ACHSPAT,0)="" Q

 .D GETDIEN

 ;

 K ACHSDOCR,X,Y,Z

 D ^ACHS3PPB         ;THIRD PARTY PAYMENT REPORT

 Q

 ;

 ;

GETDIEN ;

 S ACHSDIEN=""

 F  S ACHSDIEN=$O(^ACHSF("AC",ACHSPAT,ACHSFAC,ACHSDIEN)) Q:ACHSDIEN=""  D

 .I ACHSDIEN="",'$D(^TMP("ACHS3PP",$J,ACHSPAT)) S ^TMP("ACHS3PP",$J,ACHSPAT,0)="" Q

 .Q:'$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))!'$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"))

 .S ACHSDOCR=$G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))

 .Q:$P(ACHSDOCR,U,9)'>0

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)

 .D GETIDT

 Q

GETIDT ;

 S ACHSIDT=$P(ACHSDOCR,U,2)

 S ACHSOBL=$P(ACHSDOCR,U,9)

 S ACHSHRN=$P(ACHSDOCR,U,21)

 K Z

 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)

 .;

 .;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)      ;'IHS PAYMENT AMOUNT'

 ..S Z("3")=$G(Z("3"))+$P(X,U,8)      ;'THIRD PARTY PAY AMT'

 ;

 ;

 Q:'$D(Z)

 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,ACHSPAT,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV_U_ACHSHRN

 Q

 ;

ACHS3PPA  ; 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        SET ACHSFAC=DUZ(2)

           SET ACHSPAT=0

GETPAT    ;

 +1        FOR 

               SET ACHSPAT=$ORDER(ACHSPAT(ACHSPAT))

               IF ACHSPAT=""

                   QUIT 

               Begin DoDot:1

 +2       ;PATIENT X-REF

 +3                IF '$DATA(^ACHSF("AC",ACHSPAT))

                       SET ^TMP("ACHS3PP",$JOB,ACHSPAT,0)=""

                       QUIT 

 +4                DO GETDIEN

               End DoDot:1

 +5       ;

 +6        KILL ACHSDOCR,X,Y,Z

 +7       ;THIRD PARTY PAYMENT REPORT

           DO ^ACHS3PPB

 +8        QUIT 

 +9       ;

 +10      ;

GETDIEN   ;

 +1        SET ACHSDIEN=""

 +2        FOR 

               SET ACHSDIEN=$ORDER(^ACHSF("AC",ACHSPAT,ACHSFAC,ACHSDIEN))

               IF ACHSDIEN=""

                   QUIT 

               Begin DoDot:1

 +3                IF ACHSDIEN=""

                       IF '$DATA(^TMP("ACHS3PP",$JOB,ACHSPAT))

                           SET ^TMP("ACHS3PP",$JOB,ACHSPAT,0)=""

                           QUIT 

 +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                IF $PIECE(ACHSDOCR,U,9)'>0

                       QUIT 

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 

 +7                DO GETIDT

               End DoDot:1

 +8        QUIT 

GETIDT    ;

 +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        FOR %=0:0

               SET %=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%))

               IF '%

                   QUIT 

               Begin DoDot:1

 +6                SET X=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%,0))

 +7                SET Y=$PIECE(X,U,2)

 +8       ;

 +9       ;IF 'TRANSACTION TYPE' IS NOT "INITIAL" AND NOT "CANCEL"

 +10               IF Y'="I"

                       IF Y'="C"

                           Begin DoDot:2

 +11      ;'IHS PAYMENT AMOUNT'

                               SET Z("I")=$GET(Z("I"))+$PIECE(X,U,4)

 +12      ;'THIRD PARTY PAY AMT'

                               SET Z("3")=$GET(Z("3"))+$PIECE(X,U,8)

                           End DoDot:2

               End DoDot:1

 +13      ;

 +14      ;

 +15       IF '$DATA(Z)

               QUIT 

 +16       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)

 +17       SET ^TMP("ACHS3PP",$JOB,ACHSPAT,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV_U_ACHSHRN

 +18       QUIT 

 +19      ;