- ABPAAR1C ;COMPILE PAYMENTS FOR UTILIZATION RPT;[ 05/30/91 4:14 PM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- ABORT W *7,!!,"<<< SORRY, ACCESS DENIED!!! >>>" Q
- R0 S R=BDT-1,ABPA("TASK")=ZTSK,ABPA("UPAMT")=0,ABPA("REF")=0
- NXTR S R=$O(^ABPVAO("BD",R)) G SZTSK:+R=0,SZTSK:+R>+EDT S RR=0
- NXTRR S RR=$O(^ABPVAO("BD",R,RR)) G:+RR=0 NXTR
- I $D(^ABPVAO(RR,0))=0 G NXTRR
- I $D(^ABPVAO(RR,0))=10 G NXTRR
- I +FAC>0 I +$P(^ABPVAO(RR,0),"^",2)'=+FAC G NXTRR
- S FC=$P(^ABPVAO(RR,0),"^",2),RRR=0
- NXTRRR S RRR=$O(^ABPVAO("BD",R,RR,RRR)) G:+RRR=0 NXTRR
- I $D(^ABPVAO(RR,"P",RRR,0))=0 G NXTRRR
- I $D(^ABPVAO(RR,"P",RRR,0))=10 G NXTRRR
- S NOCHECK=1 I $P(^ABPVAO(RR,"P",RRR,0),"^",6)]"" S NOCHECK=0
- S RRRR=0 F I=1:1:15 S @("P"_I)=0
- NXTRRRR S RRRR=$O(^ABPVAO(RR,"P",RRR,"A",RRRR)) G:+RRRR=0 CLAIMS
- I $D(^ABPVAO(RR,"P",RRR,"A",RRRR,0))'=1 G NXTRRRR
- I $P(^ABPVAO(RR,"P",RRR,"A",RRRR,0),"^",2)'="S" G NXTRRRR
- I NOCHECK D G NXTRRRR
- .S X=+^ABPVAO(RR,"P",RRR,"A",RRRR,0),P10=P10+X,X=X*-1
- .S ABPA("UPAMT")=ABPA("UPAMT")+X,ABPA("REF")=ABPA("REF")+X
- S P10=P10+(+^ABPVAO(RR,"P",RRR,"A",RRRR,0)) G NXTRRRR
- CLAIMS S CDT=0 F I=0:0 D Q:+CDT=0
- .S CDT=$O(^ABPVAO(RR,"P",RRR,"D",CDT)) Q:+CDT=0
- .Q:$D(^ABPVAO(RR,"P",RRR,"D",CDT,0))'=1
- .S CDFN=$P(^ABPVAO(RR,"P",RRR,"D",CDT,0),"^",2) Q:+CDFN=0
- .Q:$D(^ABPVAO(RR,1,CDFN,0))'=1
- .S VT=$P(^ABPVAO(RR,1,CDFN,0),"^",4)
- .I (VT'="O")&(VT'="I")&(VT'="D") Q
- .I (VT="O")!(VT="D") D Q
- ..S P9=P9+$P(^ABPVAO(RR,1,CDFN,0),"^",5),P15=P15+1
- .S P8=P8+$P(^ABPVAO(RR,1,CDFN,0),"^",5),P13=P13+1
- STEMP S:$D(TEMP(ZTSK,FC))=0 TEMP(ZTSK,FC)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
- F P=1:1:15 S $P(TEMP(ZTSK,FC),"^",P)=$P(TEMP(ZTSK,FC),"^",P)+@("P"_P)
- G NXTRRR
- ;
- SZTSK S FC=0
- NXTFC S FC=$O(TEMP(ZTSK,FC)) G:+FC=0 UNDIST
- SSITE I $D(^DIC(4,FC,0))'=1 S SITENAME="UNDEFINED FACILITY" G SET1
- S SITENAME=$P(^DIC(4,FC,0),"^",1)
- SET1 S ^%ZTSK(ZTSK,SITENAME)=TEMP(ZTSK,FC),^%ZTSK(ZTSK,"SITE",SITENAME)=""
- G NXTFC
- ;
- UNDIST S R=0 F J=0:0 D Q:+R=0
- .S R=$O(^ABPACHKS("RB",1,R)) Q:+R=0
- .S RR=0 F K=0:0 D Q:+RR=0
- ..S RR=$O(^ABPACHKS("RB",1,R,RR)) Q:+RR=0
- ..S ABPACLDT=$P($P(^ABPACHKS(1,"I",R,"C",RR,0),"^",2),".")
- ..I ABPACLDT<BDT!(ABPACLDT>EDT) Q
- ..S ABPA("UPAMT")=ABPA("UPAMT")+(^ABPACHKS("RB",1,R,RR))
- S R=EDT+.9999 F I=0:0 D Q:+R=0
- .S R=$O(^ABPACHKS("SP",1,R)) Q:+R=0
- .S RR=0 F K=0:0 D Q:+RR=0
- ..S RR=$O(^ABPACHKS("SP",1,R,RR)) Q:+RR=0
- ..S RRR=0 F L=0:0 D Q:+RRR=0
- ...S RRR=$O(^ABPACHKS("SP",1,R,RR,RRR)) Q:+RRR=0
- ...S ABPACLDT=$P($P(^ABPACHKS(1,"I",RR,"C",RRR,0),"^",2),".")
- ...I ABPACLDT<BDT!(ABPACLDT>EDT) Q
- ...S ABPA("UPAMT")=ABPA("UPAMT")+^ABPACHKS("SP",1,R,RR,RRR)
- ADJUST G ADJUST^ABPAAR1E
- ABPAAR1C ;COMPILE PAYMENTS FOR UTILIZATION RPT;[ 05/30/91 4:14 PM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- ABORT WRITE *7,!!,"<<< SORRY, ACCESS DENIED!!! >>>"
- QUIT
- R0 SET R=BDT-1
- SET ABPA("TASK")=ZTSK
- SET ABPA("UPAMT")=0
- SET ABPA("REF")=0
- NXTR SET R=$ORDER(^ABPVAO("BD",R))
- IF +R=0
- GOTO SZTSK
- IF +R>+EDT
- GOTO SZTSK
- SET RR=0
- NXTRR SET RR=$ORDER(^ABPVAO("BD",R,RR))
- IF +RR=0
- GOTO NXTR
- +1 IF $DATA(^ABPVAO(RR,0))=0
- GOTO NXTRR
- +2 IF $DATA(^ABPVAO(RR,0))=10
- GOTO NXTRR
- +3 IF +FAC>0
- IF +$PIECE(^ABPVAO(RR,0),"^",2)'=+FAC
- GOTO NXTRR
- +4 SET FC=$PIECE(^ABPVAO(RR,0),"^",2)
- SET RRR=0
- NXTRRR SET RRR=$ORDER(^ABPVAO("BD",R,RR,RRR))
- IF +RRR=0
- GOTO NXTRR
- +1 IF $DATA(^ABPVAO(RR,"P",RRR,0))=0
- GOTO NXTRRR
- +2 IF $DATA(^ABPVAO(RR,"P",RRR,0))=10
- GOTO NXTRRR
- +3 SET NOCHECK=1
- IF $PIECE(^ABPVAO(RR,"P",RRR,0),"^",6)]""
- SET NOCHECK=0
- +4 SET RRRR=0
- FOR I=1:1:15
- SET @("P"_I)=0
- NXTRRRR SET RRRR=$ORDER(^ABPVAO(RR,"P",RRR,"A",RRRR))
- IF +RRRR=0
- GOTO CLAIMS
- +1 IF $DATA(^ABPVAO(RR,"P",RRR,"A",RRRR,0))'=1
- GOTO NXTRRRR
- +2 IF $PIECE(^ABPVAO(RR,"P",RRR,"A",RRRR,0),"^",2)'="S"
- GOTO NXTRRRR
- +3 IF NOCHECK
- Begin DoDot:1
- +4 SET X=+^ABPVAO(RR,"P",RRR,"A",RRRR,0)
- SET P10=P10+X
- SET X=X*-1
- +5 SET ABPA("UPAMT")=ABPA("UPAMT")+X
- SET ABPA("REF")=ABPA("REF")+X
- End DoDot:1
- GOTO NXTRRRR
- +6 SET P10=P10+(+^ABPVAO(RR,"P",RRR,"A",RRRR,0))
- GOTO NXTRRRR
- CLAIMS SET CDT=0
- FOR I=0:0
- Begin DoDot:1
- +1 SET CDT=$ORDER(^ABPVAO(RR,"P",RRR,"D",CDT))
- IF +CDT=0
- QUIT
- +2 IF $DATA(^ABPVAO(RR,"P",RRR,"D",CDT,0))'=1
- QUIT
- +3 SET CDFN=$PIECE(^ABPVAO(RR,"P",RRR,"D",CDT,0),"^",2)
- IF +CDFN=0
- QUIT
- +4 IF $DATA(^ABPVAO(RR,1,CDFN,0))'=1
- QUIT
- +5 SET VT=$PIECE(^ABPVAO(RR,1,CDFN,0),"^",4)
- +6 IF (VT'="O")&(VT'="I")&(VT'="D")
- QUIT
- +7 IF (VT="O")!(VT="D")
- Begin DoDot:2
- +8 SET P9=P9+$PIECE(^ABPVAO(RR,1,CDFN,0),"^",5)
- SET P15=P15+1
- End DoDot:2
- QUIT
- +9 SET P8=P8+$PIECE(^ABPVAO(RR,1,CDFN,0),"^",5)
- SET P13=P13+1
- End DoDot:1
- IF +CDT=0
- QUIT
- STEMP IF $DATA(TEMP(ZTSK,FC))=0
- SET TEMP(ZTSK,FC)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
- +1 FOR P=1:1:15
- SET $PIECE(TEMP(ZTSK,FC),"^",P)=$PIECE(TEMP(ZTSK,FC),"^",P)+@("P"_P)
- +2 GOTO NXTRRR
- +3 ;
- SZTSK SET FC=0
- NXTFC SET FC=$ORDER(TEMP(ZTSK,FC))
- IF +FC=0
- GOTO UNDIST
- SSITE IF $DATA(^DIC(4,FC,0))'=1
- SET SITENAME="UNDEFINED FACILITY"
- GOTO SET1
- +1 SET SITENAME=$PIECE(^DIC(4,FC,0),"^",1)
- SET1 SET ^%ZTSK(ZTSK,SITENAME)=TEMP(ZTSK,FC)
- SET ^%ZTSK(ZTSK,"SITE",SITENAME)=""
- +1 GOTO NXTFC
- +2 ;
- UNDIST SET R=0
- FOR J=0:0
- Begin DoDot:1
- +1 SET R=$ORDER(^ABPACHKS("RB",1,R))
- IF +R=0
- QUIT
- +2 SET RR=0
- FOR K=0:0
- Begin DoDot:2
- +3 SET RR=$ORDER(^ABPACHKS("RB",1,R,RR))
- IF +RR=0
- QUIT
- +4 SET ABPACLDT=$PIECE($PIECE(^ABPACHKS(1,"I",R,"C",RR,0),"^",2),".")
- +5 IF ABPACLDT<BDT!(ABPACLDT>EDT)
- QUIT
- +6 SET ABPA("UPAMT")=ABPA("UPAMT")+(^ABPACHKS("RB",1,R,RR))
- End DoDot:2
- IF +RR=0
- QUIT
- End DoDot:1
- IF +R=0
- QUIT
- +7 SET R=EDT+.9999
- FOR I=0:0
- Begin DoDot:1
- +8 SET R=$ORDER(^ABPACHKS("SP",1,R))
- IF +R=0
- QUIT
- +9 SET RR=0
- FOR K=0:0
- Begin DoDot:2
- +10 SET RR=$ORDER(^ABPACHKS("SP",1,R,RR))
- IF +RR=0
- QUIT
- +11 SET RRR=0
- FOR L=0:0
- Begin DoDot:3
- +12 SET RRR=$ORDER(^ABPACHKS("SP",1,R,RR,RRR))
- IF +RRR=0
- QUIT
- +13 SET ABPACLDT=$PIECE($PIECE(^ABPACHKS(1,"I",RR,"C",RRR,0),"^",2),".")
- +14 IF ABPACLDT<BDT!(ABPACLDT>EDT)
- QUIT
- +15 SET ABPA("UPAMT")=ABPA("UPAMT")+^ABPACHKS("SP",1,R,RR,RRR)
- End DoDot:3
- IF +RRR=0
- QUIT
- End DoDot:2
- IF +RR=0
- QUIT
- End DoDot:1
- IF +R=0
- QUIT
- ADJUST GOTO ADJUST^ABPAAR1E
