- ABPAPD2C ;DISPLAY CLAIMS FOR PAYMENT; [ 07/08/91 3:43 PM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- A0 S U="^",DC=1,D0=ABPATDFN K DXS W @IOF,! D ^ABPAPDA K DXS,ABPA("C")
- K DIC,DIE,DA,DR,ABPA("QF"),ABPACAMT,ABPACCNT,ABPA("HP"),ABPA("CP")
- S ABPADOS=ABPAFRDT-1,(ABPACAMT,ABPACCNT,ABPAOBAL,ABPATPD)=0
- S (ABPATA2,ABPATA3,ABPATA4,ABPATA5,ABPATA7)=0
- F ABPA("I")=0:0 D Q:$D(ABPA("QF",1))=1
- .S ABPADOS=$O(^ABPVAO("PC",ABPATDFN,ABPADOS))
- .I +ABPADOS=0!(ABPADOS>ABPATODT) S ABPA("QF",1)="" Q
- .K ABPA("QF",2) S DA=0 F ABPA("II")=0:0 D Q:$D(ABPA("QF",2))=1
- ..S DA=$O(^ABPVAO("PC",ABPATDFN,ABPADOS,DA))
- ..I +DA=0 S ABPA("QF",2)="" Q
- ..Q:$D(^ABPVAO(ABPATDFN,1,DA,0))'=1!($D(ABPACSCR(+DA))=1)
- ..S ABPAPTR=+DA,ABPADATA=^ABPVAO(ABPATDFN,1,ABPAPTR,0)
- ..S ABPA("CP",ABPADOS,DA)="0^0^0^0^0^0"
- ..S ABPA("HP",ABPADOS,DA)=ABPA("CP",ABPADOS,DA)
- ..;-------------------------------------------------------------------
- ..;PROCEDURE TO BUILD PAYMENT HISTORY ARRAY
- ..F ABPAJ=2:1:5 S @("ABPAP"_ABPAJ)=0
- ..S ABPAZ=0 F ABPAJ=0:0 S ABPAPTOT=0 D Q:+ABPAZ=0
- ...S ABPAZ=$O(^ABPVAO("PD",ABPATDFN,DA,ABPAZ)) Q:+ABPAZ=0
- ...S ABPAZZ=0 F ABPAK=0:0 D Q:+ABPAZZ=0
- ....S ABPAZZ=$O(^ABPVAO(ABPATDFN,"P",ABPAZ,"D",ABPAZZ)) Q:+ABPAZZ=0
- ....Q:$D(^ABPVAO(ABPATDFN,"P",ABPAZ,"D",ABPAZZ,0))'=1 S ABPARCD=^(0)
- ....Q:$P(ABPARCD,"^",2)'=DA F ABPAL=3:1:6 D
- .....S @("ABPAP"_(ABPAL-1))=@("ABPAP"_(ABPAL-1))+$P(ABPARCD,"^",ABPAL)
- ..S ABPAPTOT=ABPAP2+ABPAP3+ABPAP4+ABPAP5,ABPATPD=ABPATPD+ABPAPTOT
- ..S ABPABAL=($P(ABPADATA,"^",7)-ABPAPTOT)-(+$P(ABPADATA,"^",3))
- ..S $P(ABPA("HP",ABPADOS,DA),"^")=ABPABAL,ABPAOBAL=ABPAOBAL+ABPABAL
- ..F ABPAJ=2:1:5 S $P(ABPA("HP",ABPADOS,DA),"^",ABPAJ)=@("ABPAP"_ABPAJ)
- ..S $P(ABPA("HP",ABPADOS,DA),"^",6)=ABPAPTOT
- ..S $P(ABPA("HP",ABPADOS,DA),"^",7)=+$P(ABPADATA,"^",3)
- ..;-------------------------------------------------------------------
- ..S ABPACCNT=ABPACCNT+1,ABPA("C",ABPACCNT)=DA
- ..W !,ABPACCNT,?2,$J($P(ABPADATA,"^",2),7)
- ..S ABPA("DTIN")=+ABPADATA D DTCVT^ABPAMAIN W ?10,$J(ABPA("DTOUT"),8)
- ..W ?19,$J($P(ABPADATA,"^",7),8,2)
- ..S ABPACAMT=ABPACAMT+$P(ABPADATA,"^",7)
- ..F I=28,37 S J=$E(I) D
- ...W ?I,$J($P(ABPA("HP",ABPADOS,DA),"^",J),8,2)
- ...S @("ABPATA"_J)=@("ABPATA"_J)+$P(ABPA("HP",ABPADOS,DA),"^",J)
- ..W ?46,$J($P(ABPA("HP",ABPADOS,DA),"^",4),7,2)
- ..S ABPATA4=ABPATA4+$P(ABPA("HP",ABPADOS,DA),"^",4)
- ..W ?54,$J($P(ABPA("HP",ABPADOS,DA),"^",5),8,2)
- ..S ABPATA5=ABPATA5+$P(ABPA("HP",ABPADOS,DA),"^",5)
- ..W ?63,$J($P(ABPA("HP",ABPADOS,DA),"^",7),8,2)
- ..S ABPATA7=ABPATA7+$P(ABPA("HP",ABPADOS,DA),"^",7)
- ..W ?72,$J(ABPABAL,8,2)
- I +ABPACCNT<1 D Q
- .W !!?5,*7,"<<< NO 'ELIGIBLE' CLAIMS FOUND FOR THIS DATE OF SERVICE "
- .W "PERIOD >>>" H 3
- I +ABPACCNT>1 W ! D
- .F ABPAI=19,28,37 W ?(ABPAI),"--------"
- .W ?46,"-------",?54,"--------",?63,"--------",?72,"--------"
- .W !?19,$J(ABPACAMT,8,2),?28,$J(ABPATA2,8,2),?37,$J(ABPATA3,8,2)
- .W ?46,$J(ABPATA4,7,2),?54,$J(ABPATA5,8,2)
- .W ?63,$J(ABPATA7,8,2),?72,$J(ABPAOBAL,8,2)
- W !,ABPAXX
- Q
- ABPAPD2C ;DISPLAY CLAIMS FOR PAYMENT; [ 07/08/91 3:43 PM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- A0 SET U="^"
- SET DC=1
- SET D0=ABPATDFN
- KILL DXS
- WRITE @IOF,!
- DO ^ABPAPDA
- KILL DXS,ABPA("C")
- +1 KILL DIC,DIE,DA,DR,ABPA("QF"),ABPACAMT,ABPACCNT,ABPA("HP"),ABPA("CP")
- +2 SET ABPADOS=ABPAFRDT-1
- SET (ABPACAMT,ABPACCNT,ABPAOBAL,ABPATPD)=0
- +3 SET (ABPATA2,ABPATA3,ABPATA4,ABPATA5,ABPATA7)=0
- +4 FOR ABPA("I")=0:0
- Begin DoDot:1
- +5 SET ABPADOS=$ORDER(^ABPVAO("PC",ABPATDFN,ABPADOS))
- +6 IF +ABPADOS=0!(ABPADOS>ABPATODT)
- SET ABPA("QF",1)=""
- QUIT
- +7 KILL ABPA("QF",2)
- SET DA=0
- FOR ABPA("II")=0:0
- Begin DoDot:2
- +8 SET DA=$ORDER(^ABPVAO("PC",ABPATDFN,ABPADOS,DA))
- +9 IF +DA=0
- SET ABPA("QF",2)=""
- QUIT
- +10 IF $DATA(^ABPVAO(ABPATDFN,1,DA,0))'=1!($DATA(ABPACSCR(+DA))=1)
- QUIT
- +11 SET ABPAPTR=+DA
- SET ABPADATA=^ABPVAO(ABPATDFN,1,ABPAPTR,0)
- +12 SET ABPA("CP",ABPADOS,DA)="0^0^0^0^0^0"
- +13 SET ABPA("HP",ABPADOS,DA)=ABPA("CP",ABPADOS,DA)
- +14 ;-------------------------------------------------------------------
- +15 ;PROCEDURE TO BUILD PAYMENT HISTORY ARRAY
- +16 FOR ABPAJ=2:1:5
- SET @("ABPAP"_ABPAJ)=0
- +17 SET ABPAZ=0
- FOR ABPAJ=0:0
- SET ABPAPTOT=0
- Begin DoDot:3
- +18 SET ABPAZ=$ORDER(^ABPVAO("PD",ABPATDFN,DA,ABPAZ))
- IF +ABPAZ=0
- QUIT
- +19 SET ABPAZZ=0
- FOR ABPAK=0:0
- Begin DoDot:4
- +20 SET ABPAZZ=$ORDER(^ABPVAO(ABPATDFN,"P",ABPAZ,"D",ABPAZZ))
- IF +ABPAZZ=0
- QUIT
- +21 IF $DATA(^ABPVAO(ABPATDFN,"P",ABPAZ,"D",ABPAZZ,0))'=1
- QUIT
- SET ABPARCD=^(0)
- +22 IF $PIECE(ABPARCD,"^",2)'=DA
- QUIT
- FOR ABPAL=3:1:6
- Begin DoDot:5
- +23 SET @("ABPAP"_(ABPAL-1))=@("ABPAP"_(ABPAL-1))+$PIECE(ABPARCD,"^",ABPAL)
- End DoDot:5
- End DoDot:4
- IF +ABPAZZ=0
- QUIT
- End DoDot:3
- IF +ABPAZ=0
- QUIT
- +24 SET ABPAPTOT=ABPAP2+ABPAP3+ABPAP4+ABPAP5
- SET ABPATPD=ABPATPD+ABPAPTOT
- +25 SET ABPABAL=($PIECE(ABPADATA,"^",7)-ABPAPTOT)-(+$PIECE(ABPADATA,"^",3))
- +26 SET $PIECE(ABPA("HP",ABPADOS,DA),"^")=ABPABAL
- SET ABPAOBAL=ABPAOBAL+ABPABAL
- +27 FOR ABPAJ=2:1:5
- SET $PIECE(ABPA("HP",ABPADOS,DA),"^",ABPAJ)=@("ABPAP"_ABPAJ)
- +28 SET $PIECE(ABPA("HP",ABPADOS,DA),"^",6)=ABPAPTOT
- +29 SET $PIECE(ABPA("HP",ABPADOS,DA),"^",7)=+$PIECE(ABPADATA,"^",3)
- +30 ;-------------------------------------------------------------------
- +31 SET ABPACCNT=ABPACCNT+1
- SET ABPA("C",ABPACCNT)=DA
- +32 WRITE !,ABPACCNT,?2,$JUSTIFY($PIECE(ABPADATA,"^",2),7)
- +33 SET ABPA("DTIN")=+ABPADATA
- DO DTCVT^ABPAMAIN
- WRITE ?10,$JUSTIFY(ABPA("DTOUT"),8)
- +34 WRITE ?19,$JUSTIFY($PIECE(ABPADATA,"^",7),8,2)
- +35 SET ABPACAMT=ABPACAMT+$PIECE(ABPADATA,"^",7)
- +36 FOR I=28,37
- SET J=$EXTRACT(I)
- Begin DoDot:3
- +37 WRITE ?I,$JUSTIFY($PIECE(ABPA("HP",ABPADOS,DA),"^",J),8,2)
- +38 SET @("ABPATA"_J)=@("ABPATA"_J)+$PIECE(ABPA("HP",ABPADOS,DA),"^",J)
- End DoDot:3
- +39 WRITE ?46,$JUSTIFY($PIECE(ABPA("HP",ABPADOS,DA),"^",4),7,2)
- +40 SET ABPATA4=ABPATA4+$PIECE(ABPA("HP",ABPADOS,DA),"^",4)
- +41 WRITE ?54,$JUSTIFY($PIECE(ABPA("HP",ABPADOS,DA),"^",5),8,2)
- +42 SET ABPATA5=ABPATA5+$PIECE(ABPA("HP",ABPADOS,DA),"^",5)
- +43 WRITE ?63,$JUSTIFY($PIECE(ABPA("HP",ABPADOS,DA),"^",7),8,2)
- +44 SET ABPATA7=ABPATA7+$PIECE(ABPA("HP",ABPADOS,DA),"^",7)
- +45 WRITE ?72,$JUSTIFY(ABPABAL,8,2)
- End DoDot:2
- IF $DATA(ABPA("QF",2))=1
- QUIT
- End DoDot:1
- IF $DATA(ABPA("QF",1))=1
- QUIT
- +46 IF +ABPACCNT<1
- Begin DoDot:1
- +47 WRITE !!?5,*7,"<<< NO 'ELIGIBLE' CLAIMS FOUND FOR THIS DATE OF SERVICE "
- +48 WRITE "PERIOD >>>"
- HANG 3
- End DoDot:1
- QUIT
- +49 IF +ABPACCNT>1
- WRITE !
- Begin DoDot:1
- +50 FOR ABPAI=19,28,37
- WRITE ?(ABPAI),"--------"
- +51 WRITE ?46,"-------",?54,"--------",?63,"--------",?72,"--------"
- +52 WRITE !?19,$JUSTIFY(ABPACAMT,8,2),?28,$JUSTIFY(ABPATA2,8,2),?37,$JUSTIFY(ABPATA3,8,2)
- +53 WRITE ?46,$JUSTIFY(ABPATA4,7,2),?54,$JUSTIFY(ABPATA5,8,2)
- +54 WRITE ?63,$JUSTIFY(ABPATA7,8,2),?72,$JUSTIFY(ABPAOBAL,8,2)
- End DoDot:1
- +55 WRITE !,ABPAXX
- +56 QUIT
