- ACHS3PPC ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT (ALL PATIENTS) ; [ 04/17/2002 1:56 PM ]
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,16**;JUN 11, 2001
- ;ACHS*3.1*4 repair quit statement
- ;ACHS*3.1*16 IHS.OIT.FCJ Added amount for insurers
- ;
- I '$D(ACHSPAT(0)) G ^ACHS3PPA ;THIRD PARTY PAYMENT REPORT
- ;
- S ACHSFAC=DUZ(2),ACHSFY1=""
- GETFY ;
- S ACHSFY1=$O(^ACHSF(ACHSFAC,"D","B",ACHSFY1))
- I ACHSFY1="",'$D(^TMP("ACHS3PP",$J,ACHSFAC)) S ^TMP("ACHS3PP",$J,ACHSFAC,0)=""
- ;
- I ACHSFY1="" K ACHSDOCR,X,Y,Z G ^ACHS3PPP ;PRINT THIRD PARTY PAYMENT REPORT (ALL PATS)
- ;
- S ACHSFYA=$E(ACHSFY1,2),ACHSFYB=$E(ACHSFY,4)
- I ACHSFYA'=ACHSFYB G GETFY
- ;
- D GETDIEN
- G GETFY
- Q
- ;
- ;MAIN LOOP
- 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"))
- .;
- .;SKIP IF 'TOTAL AMOUNT OBLIGATED' ?????WHAT ABOUT NEGATIVES?????
- .Q:$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,9)'>0
- .S ACHSDOCR=$G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)) ;GET DOCUMENT 0 NODE
- .;
- .;GET 'TYPE OF SERVICE'
- .S ACHSSERV=$S($P(ACHSDOCR,U,4):$P(ACHSDOCR,U,4),1:"UNKN")
- .;
- .;ACHSSER=4 MEANS ALL TYPES
- .Q:'(ACHSSER=4)&(ACHSSERV'=ACHSSER)
- .D GETIDT
- Q
- ;
- GETIDT ;
- S ACHSIDT=$P(ACHSDOCR,U,2) ;'ORDER DATE'
- S ACHSOBL=$P(ACHSDOCR,U,9) ;'TOTAL OBLIGATED AMOUNT'
- K Z
- ;
- ;GO THROUGH TRANSACTIONS
- 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) ;'TRANSACTION TYPE'
- .;
- .;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) ;ADD IN 'IHS PAYMENT AMOUNT'
- ..S Z("3")=$G(Z("3"))+$P(X,U,8) ;ADD IN 'THIRD PARTY PAY AMT'
- ..;ACHS*3.1*16 IHS.OIT.FCJ ADDED NXT SECTION FOR DETAIL TP INSURER
- ..I (ACHSRTYP="T")!(ACHSRTYP="P") D
- ...I $P(X,U,12)="",$P(X,U,8)>0 S:'$D(Z("TP","U")) Z("TP","U")=0 S Z("TP","U")=Z("TP","U")+$P(X,U,8) Q ;UNIDENTIFIED INSURANCE
- ...I $P(X,U,12)="",$P(X,U,8)<1 S:'$D(Z("TP","I")) Z("TP","I")=0 S Z("TP","I")=Z("TP","I")+$P(X,U,4) Q ;IHS PAY DOCUMENTS
- ...I '$D(Z("T",$P(X,U,12))) S Z("T",$P(X,U,12))=$P(X,U,8)
- ...E S Z("T",$P(X,U,12))=Z("T",$P(X,U,12))+$P(X,U,8)
- ;
- ;ACHS*3.1*4 3/26/02 pmf just wanna quit Q:'$D(Z) GETDIEN
- I '$D(Z) Q ; ACHS*3.1*4```````1=($G(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$E($P($G(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_$P(ACHSDOCR,U)
- ;
- ;GET 'FISCAL YEAR' _ 'PREFIX/REGION' _ 'FINANCIAL LOCATION CODE' _
- ;'ORDER NUMBER'
- 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,ACHSFAC,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV
- ;ACHS*3.1*16 IHS.OIT.FCJ ADDED 3 NXT LINES
- I (ACHSRTYP="T")!(ACHSRTYP="P") D
- .F X="I","U" S:$D(Z("TP",X)) ^TMP("ACHS3PP",$J,ACHSFAC,X,ACHSDOC)=Z("TP",X)
- .S X="" F S X=$O(Z("T",X)) Q:X="" S ^TMP("ACHS3PP",$J,ACHSFAC,"T",X,ACHSDOC)=Z("T",X)
- Q
- ;
- ACHS3PPC ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT (ALL PATIENTS) ; [ 04/17/2002 1:56 PM ]
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,16**;JUN 11, 2001
- +2 ;ACHS*3.1*4 repair quit statement
- +3 ;ACHS*3.1*16 IHS.OIT.FCJ Added amount for insurers
- +4 ;
- +5 ;THIRD PARTY PAYMENT REPORT
- IF '$DATA(ACHSPAT(0))
- GOTO ^ACHS3PPA
- +6 ;
- +7 SET ACHSFAC=DUZ(2)
- SET ACHSFY1=""
- GETFY ;
- +1 SET ACHSFY1=$ORDER(^ACHSF(ACHSFAC,"D","B",ACHSFY1))
- +2 IF ACHSFY1=""
- IF '$DATA(^TMP("ACHS3PP",$JOB,ACHSFAC))
- SET ^TMP("ACHS3PP",$JOB,ACHSFAC,0)=""
- +3 ;
- +4 ;PRINT THIRD PARTY PAYMENT REPORT (ALL PATS)
- IF ACHSFY1=""
- KILL ACHSDOCR,X,Y,Z
- GOTO ^ACHS3PPP
- +5 ;
- +6 SET ACHSFYA=$EXTRACT(ACHSFY1,2)
- SET ACHSFYB=$EXTRACT(ACHSFY,4)
- +7 IF ACHSFYA'=ACHSFYB
- GOTO GETFY
- +8 ;
- +9 DO GETDIEN
- +10 GOTO GETFY
- +11 QUIT
- +12 ;
- +13 ;MAIN LOOP
- 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 ;
- +5 ;SKIP IF 'TOTAL AMOUNT OBLIGATED' ?????WHAT ABOUT NEGATIVES?????
- +6 IF $PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,9)'>0
- QUIT
- +7 ;GET DOCUMENT 0 NODE
- SET ACHSDOCR=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))
- +8 ;
- +9 ;GET 'TYPE OF SERVICE'
- +10 SET ACHSSERV=$SELECT($PIECE(ACHSDOCR,U,4):$PIECE(ACHSDOCR,U,4),1:"UNKN")
- +11 ;
- +12 ;ACHSSER=4 MEANS ALL TYPES
- +13 IF '(ACHSSER=4)&(ACHSSERV'=ACHSSER)
- QUIT
- +14 DO GETIDT
- End DoDot:1
- +15 QUIT
- +16 ;
- GETIDT ;
- +1 ;'ORDER DATE'
- SET ACHSIDT=$PIECE(ACHSDOCR,U,2)
- +2 ;'TOTAL OBLIGATED AMOUNT'
- SET ACHSOBL=$PIECE(ACHSDOCR,U,9)
- +3 KILL Z
- +4 ;
- +5 ;GO THROUGH TRANSACTIONS
- +6 FOR %=0:0
- SET %=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%))
- IF '%
- QUIT
- Begin DoDot:1
- +7 SET X=$GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%,0))
- +8 ;
- +9 ;'TRANSACTION TYPE'
- SET Y=$PIECE(X,U,2)
- +10 ;
- +11 ;IF 'TRANSACTION TYPE' IS NOT "INITIAL" AND NOT "CANCEL"
- +12 IF Y'="I"
- IF Y'="C"
- Begin DoDot:2
- +13 ;ADD IN 'IHS PAYMENT AMOUNT'
- SET Z("I")=$GET(Z("I"))+$PIECE(X,U,4)
- +14 ;ADD IN 'THIRD PARTY PAY AMT'
- SET Z("3")=$GET(Z("3"))+$PIECE(X,U,8)
- +15 ;ACHS*3.1*16 IHS.OIT.FCJ ADDED NXT SECTION FOR DETAIL TP INSURER
- +16 IF (ACHSRTYP="T")!(ACHSRTYP="P")
- Begin DoDot:3
- +17 ;UNIDENTIFIED INSURANCE
- IF $PIECE(X,U,12)=""
- IF $PIECE(X,U,8)>0
- IF '$DATA(Z("TP","U"))
- SET Z("TP","U")=0
- SET Z("TP","U")=Z("TP","U")+$PIECE(X,U,8)
- QUIT
- +18 ;IHS PAY DOCUMENTS
- IF $PIECE(X,U,12)=""
- IF $PIECE(X,U,8)<1
- IF '$DATA(Z("TP","I"))
- SET Z("TP","I")=0
- SET Z("TP","I")=Z("TP","I")+$PIECE(X,U,4)
- QUIT
- +19 IF '$DATA(Z("T",$PIECE(X,U,12)))
- SET Z("T",$PIECE(X,U,12))=$PIECE(X,U,8)
- +20 IF '$TEST
- SET Z("T",$PIECE(X,U,12))=Z("T",$PIECE(X,U,12))+$PIECE(X,U,8)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 ;
- +22 ;ACHS*3.1*4 3/26/02 pmf just wanna quit Q:'$D(Z) GETDIEN
- +23 ; ACHS*3.1*4```````1=($G(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$E($P($G(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_$P(ACHSDOCR,U)
- IF '$DATA(Z)
- QUIT
- +24 ;
- +25 ;GET 'FISCAL YEAR' _ 'PREFIX/REGION' _ 'FINANCIAL LOCATION CODE' _
- +26 ;'ORDER NUMBER'
- +27 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)
- +28 ;
- +29 SET ^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC)=ACHSIDT_U_ACHSOBL_U_Z("3")_U_Z("I")_U_ACHSSERV
- +30 ;ACHS*3.1*16 IHS.OIT.FCJ ADDED 3 NXT LINES
- +31 IF (ACHSRTYP="T")!(ACHSRTYP="P")
- Begin DoDot:1
- +32 FOR X="I","U"
- IF $DATA(Z("TP",X))
- SET ^TMP("ACHS3PP",$JOB,ACHSFAC,X,ACHSDOC)=Z("TP",X)
- +33 SET X=""
- FOR
- SET X=$ORDER(Z("T",X))
- IF X=""
- QUIT
- SET ^TMP("ACHS3PP",$JOB,ACHSFAC,"T",X,ACHSDOC)=Z("T",X)
- End DoDot:1
- +34 QUIT
- +35 ;
