ABPAADR1 ;COMPILE PAYMENTS FOR DISTRIBUTION RPT;[ 06/27/91 2:11 PM ]
;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
;KEY VARIABLES: R = BATCH DATE
; RR = PATIENT DFN
; RRR = PAYMENT DFN WITHIN PATIENT RECORD
; RRRR = PAYMENT AMOUNT DFN WITHIN PATIENT NODE
;
G ABORT
R0 S R=BDT-1,ABPA("TASK")=ZTSK
NXTR S R=$O(^ABPVAO("DP",R)) G SZTSK:+R=0,SZTSK:+R>+EDT S RR=0
NXTRR S RR=$O(^ABPVAO("DP",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("DP",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 RRRR=0 F I=1:1:15 S @("P"_I)=0
NXTRRRR S RRRR=$O(^ABPVAO(RR,"P",RRR,"A",RRRR)) G:+RRRR=0 STEMP
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
S P10=P10+(+$P(^ABPVAO(RR,"P",RRR,"A",RRRR,0),"^")) G NXTRRRR
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 ZTLOAD
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
;
ZTLOAD S PRINTNOW=0,MTH=+$E(DT,4,5) D I 'AUTO S PRINTNOW=1
.S ABPA("LD")=$P("31^28^31^30^31^30^31^31^30^31^30^31","^",MTH)
I AUTO&(+$E(DT,6,7)=ABPA("LD")) S PRINTNOW=1
I AUTO&(MTH=2)&(+$E(DT,6,7)=29) S PRINTNOW=1
I PRINTNOW D
.I $D(ABPA("IO"))'=1 S ABPA("IO")=+IO
.I +DUZ(2)'>0 S DUZ(2)=$O(^ABPAFAC(+DUZ(2)))
.S ZTRTN="MAIN^ABPAADR2",ZTDTH=$H,ZTIO=ABPA("IO"),ZTSAVE("ABPA(")=""
.S ZTSAVE("BDT")="",ZTSAVE("EDT")="",ZTSAVE("FAC")=""
.S ZTDESC="PRINT PVT INS DISTRIBUTION REPORT" D ^%ZTLOAD
ZTLEND K BDT,EDT,FAC,FC,IPD,IPV,LBL,OPD,OPV,ZTRTN,ZTDTH,ZTIO,ZTSAVE
F I=1:1:13 K @("P"_I)
K R,RR,RRR,RRRR,SITENAME,VD,VT,PTOT,J,I,TEMP,ABPA
Q
;
PRINT K ABPA("HD") S ABPA("HD",1)=ABPATLE,ABPA("HD",2)=$P(XQO,"^",2)
D ^ABPAHD S ZTSK=0,FOUND=0 F J=0:0 D Q:+ZTSK=0
.S ZTSK=$O(^%ZTSK(ZTSK)) Q:+ZTSK=0
.Q:$D(^%ZTSK(ZTSK,0))'=11 S DATA=(^(0))
.Q:$P(DATA,"^")'="R0" Q:$P(DATA,"^",2)'="ABPAADR1"
.Q:$D(^%ZTSK(ZTSK,0,"AUTO"))'=1 Q:^("AUTO")'=1
.Q:$D(^%ZTSK(ZTSK,0,"ABPA(","RPTYP"))'=1
.Q:^("RPTYP")'=ABPA("RPTYP")
.S FOUND=ZTSK,ABPA("TASK")=ZTSK,BDT=^%ZTSK(ZTSK,0,"BDT")
.S EDT=^%ZTSK(ZTSK,0,"EDT"),FAC=^%ZTSK(ZTSK,0,"FAC")
W !!! K ABPA("IO") F J=0:0 D Q:$D(ABPA("IO"))=1!(POP)
.K %IS,IOP S %IS="NP",%IS("A")="Select PRINTER: " D ^%ZIS
.Q:POP I $E(IOST,1)'="P" D Q
..W *7,?5,"<<< NOT A PRINTER DEVICE >>>"
.S ABPA("IO")=+IO
I FOUND&($D(ABPA("IO"))=1) W !! D WAIT^DICD G MAIN^ABPAADR2
G ZTLEND
;
ABORT W *7,!!,"<<< SORRY, ACCESS DENIED!!! >>>" G ZTLEND
ABPAADR1 ;COMPILE PAYMENTS FOR DISTRIBUTION RPT;[ 06/27/91 2:11 PM ]
+1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
+2 ;KEY VARIABLES: R = BATCH DATE
+3 ; RR = PATIENT DFN
+4 ; RRR = PAYMENT DFN WITHIN PATIENT RECORD
+5 ; RRRR = PAYMENT AMOUNT DFN WITHIN PATIENT NODE
+6 ;
+7 GOTO ABORT
R0 SET R=BDT-1
SET ABPA("TASK")=ZTSK
NXTR SET R=$ORDER(^ABPVAO("DP",R))
IF +R=0
GOTO SZTSK
IF +R>+EDT
GOTO SZTSK
SET RR=0
NXTRR SET RR=$ORDER(^ABPVAO("DP",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("DP",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 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 STEMP
+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 SET P10=P10+(+$PIECE(^ABPVAO(RR,"P",RRR,"A",RRRR,0),"^"))
GOTO NXTRRRR
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 ZTLOAD
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 ;
ZTLOAD SET PRINTNOW=0
SET MTH=+$EXTRACT(DT,4,5)
Begin DoDot:1
+1 SET ABPA("LD")=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31","^",MTH)
End DoDot:1
IF 'AUTO
SET PRINTNOW=1
+2 IF AUTO&(+$EXTRACT(DT,6,7)=ABPA("LD"))
SET PRINTNOW=1
+3 IF AUTO&(MTH=2)&(+$EXTRACT(DT,6,7)=29)
SET PRINTNOW=1
+4 IF PRINTNOW
Begin DoDot:1
+5 IF $DATA(ABPA("IO"))'=1
SET ABPA("IO")=+IO
+6 IF +DUZ(2)'>0
SET DUZ(2)=$ORDER(^ABPAFAC(+DUZ(2)))
+7 SET ZTRTN="MAIN^ABPAADR2"
SET ZTDTH=$HOROLOG
SET ZTIO=ABPA("IO")
SET ZTSAVE("ABPA(")=""
+8 SET ZTSAVE("BDT")=""
SET ZTSAVE("EDT")=""
SET ZTSAVE("FAC")=""
+9 SET ZTDESC="PRINT PVT INS DISTRIBUTION REPORT"
DO ^%ZTLOAD
End DoDot:1
ZTLEND KILL BDT,EDT,FAC,FC,IPD,IPV,LBL,OPD,OPV,ZTRTN,ZTDTH,ZTIO,ZTSAVE
+1 FOR I=1:1:13
KILL @("P"_I)
+2 KILL R,RR,RRR,RRRR,SITENAME,VD,VT,PTOT,J,I,TEMP,ABPA
+3 QUIT
+4 ;
PRINT KILL ABPA("HD")
SET ABPA("HD",1)=ABPATLE
SET ABPA("HD",2)=$PIECE(XQO,"^",2)
+1 DO ^ABPAHD
SET ZTSK=0
SET FOUND=0
FOR J=0:0
Begin DoDot:1
+2 SET ZTSK=$ORDER(^%ZTSK(ZTSK))
IF +ZTSK=0
QUIT
+3 IF $DATA(^%ZTSK(ZTSK,0))'=11
QUIT
SET DATA=(^(0))
+4 IF $PIECE(DATA,"^")'="R0"
QUIT
IF $PIECE(DATA,"^",2)'="ABPAADR1"
QUIT
+5 IF $DATA(^%ZTSK(ZTSK,0,"AUTO"))'=1
QUIT
IF ^("AUTO")'=1
QUIT
+6 IF $DATA(^%ZTSK(ZTSK,0,"ABPA(","RPTYP"))'=1
QUIT
+7 IF ^("RPTYP")'=ABPA("RPTYP")
QUIT
+8 SET FOUND=ZTSK
SET ABPA("TASK")=ZTSK
SET BDT=^%ZTSK(ZTSK,0,"BDT")
+9 SET EDT=^%ZTSK(ZTSK,0,"EDT")
SET FAC=^%ZTSK(ZTSK,0,"FAC")
End DoDot:1
IF +ZTSK=0
QUIT
+10 WRITE !!!
KILL ABPA("IO")
FOR J=0:0
Begin DoDot:1
+11 KILL %IS,IOP
SET %IS="NP"
SET %IS("A")="Select PRINTER: "
DO ^%ZIS
+12 IF POP
QUIT
IF $EXTRACT(IOST,1)'="P"
Begin DoDot:2
+13 WRITE *7,?5,"<<< NOT A PRINTER DEVICE >>>"
End DoDot:2
QUIT
+14 SET ABPA("IO")=+IO
End DoDot:1
IF $DATA(ABPA("IO"))=1!(POP)
QUIT
+15 IF FOUND&($DATA(ABPA("IO"))=1)
WRITE !!
DO WAIT^DICD
GOTO MAIN^ABPAADR2
+16 GOTO ZTLEND
+17 ;
ABORT WRITE *7,!!,"<<< SORRY, ACCESS DENIED!!! >>>"
GOTO ZTLEND
