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
