ACHS3PP1.m

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      ;