ABPAAR1E ;COMPILE PAYMENTS FOR UTILIZATION RPT;[ 06/27/91 1:48 PM ]
;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
ABORT W *7,!!,"<<< SORRY, ACCESS DENIED!!! >>>" G ZTLEND
ADJUST S R=BDT,ABPA("TRAN")=0 F J=0:0 D Q:+R=0
.S R=$O(^ABPACHKS("SP",1,R)) Q:+R=0!(+R>(EDT+.9999))
.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),".")
...Q:$D(^ABPACHKS(1,"I",RR,"C",RRR,"SP","B",R))=0
...S DA=$O(^ABPACHKS(1,"I",RR,"C",RRR,"SP","B",R,"")) Q:+DA'>0
...Q:$D(^ABPACHKS(1,"I",RR,"C",RRR,"SP",DA,0))'=1
...S ABPASP=$P(^ABPACHKS(1,"I",RR,"C",RRR,"SP",DA,0),"^",2)
...I ABPASP="T" D Q
....S ABPA("TRAN")=ABPA("TRAN")+^ABPACHKS("SP",1,R,RR,RRR)
....I ABPACLDT'<BDT&(ABPACLDT'>EDT) D
.....S ABPA("UPAMT")=ABPA("UPAMT")+^ABPACHKS("SP",1,R,RR,RRR)
...I ABPASP="R" D Q
....S ABPA("REF")=ABPA("REF")+^ABPACHKS("SP",1,R,RR,RRR)
....I ABPACLDT'<BDT&(ABPACLDT'>EDT) D
.....S ABPA("UPAMT")=ABPA("UPAMT")+^ABPACHKS("SP",1,R,RR,RRR)
S ^%ZTSK(ZTSK,0,"ABPA(","UPAMT")=ABPA("UPAMT")
S ^%ZTSK(ZTSK,0,"ABPA(","TRAN")=ABPA("TRAN")
S ^%ZTSK(ZTSK,0,"ABPA(","REF")=ABPA("REF")
;
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="START^ABPAAR1D",ZTDTH=$H,ZTIO=ABPA("IO"),ZTSAVE("ABPA(")=""
.S ZTSAVE("BDT")="",ZTSAVE("EDT")="",ZTSAVE("FAC")=""
.S ZTDESC="PRINT PVT INS UTILILIZATION 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,PRINTNOW
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)'="ABPAAR1B"
.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")
.I $D(^%ZTSK(ZTSK,0,"ABPA(","UPAMT"))=1 S ABPA("UPAMT")=^("UPAMT")
.I $D(^%ZTSK(ZTSK,0,"ABPA(","TRAN"))=1 S ABPA("TRAN")=^("TRAN")
.I $D(^%ZTSK(ZTSK,0,"ABPA(","REF"))=1 S ABPA("REF")=^("REF")
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 START^ABPAAR1D
G ZTLEND
ABPAAR1E ;COMPILE PAYMENTS FOR UTILIZATION RPT;[ 06/27/91 1:48 PM ]
+1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
ABORT WRITE *7,!!,"<<< SORRY, ACCESS DENIED!!! >>>"
GOTO ZTLEND
ADJUST SET R=BDT
SET ABPA("TRAN")=0
FOR J=0:0
Begin DoDot:1
+1 SET R=$ORDER(^ABPACHKS("SP",1,R))
IF +R=0!(+R>(EDT+.9999))
QUIT
+2 SET RR=0
FOR K=0:0
Begin DoDot:2
+3 SET RR=$ORDER(^ABPACHKS("SP",1,R,RR))
IF +RR=0
QUIT
+4 SET RRR=0
FOR L=0:0
Begin DoDot:3
+5 SET RRR=$ORDER(^ABPACHKS("SP",1,R,RR,RRR))
IF +RRR=0
QUIT
+6 SET ABPACLDT=$PIECE($PIECE(^ABPACHKS(1,"I",RR,"C",RRR,0),"^",2),".")
+7 IF $DATA(^ABPACHKS(1,"I",RR,"C",RRR,"SP","B",R))=0
QUIT
+8 SET DA=$ORDER(^ABPACHKS(1,"I",RR,"C",RRR,"SP","B",R,""))
IF +DA'>0
QUIT
+9 IF $DATA(^ABPACHKS(1,"I",RR,"C",RRR,"SP",DA,0))'=1
QUIT
+10 SET ABPASP=$PIECE(^ABPACHKS(1,"I",RR,"C",RRR,"SP",DA,0),"^",2)
+11 IF ABPASP="T"
Begin DoDot:4
+12 SET ABPA("TRAN")=ABPA("TRAN")+^ABPACHKS("SP",1,R,RR,RRR)
+13 IF ABPACLDT'<BDT&(ABPACLDT'>EDT)
Begin DoDot:5
+14 SET ABPA("UPAMT")=ABPA("UPAMT")+^ABPACHKS("SP",1,R,RR,RRR)
End DoDot:5
End DoDot:4
QUIT
+15 IF ABPASP="R"
Begin DoDot:4
+16 SET ABPA("REF")=ABPA("REF")+^ABPACHKS("SP",1,R,RR,RRR)
+17 IF ABPACLDT'<BDT&(ABPACLDT'>EDT)
Begin DoDot:5
+18 SET ABPA("UPAMT")=ABPA("UPAMT")+^ABPACHKS("SP",1,R,RR,RRR)
End DoDot:5
End DoDot:4
QUIT
End DoDot:3
IF +RRR=0
QUIT
End DoDot:2
IF +RR=0
QUIT
End DoDot:1
IF +R=0
QUIT
+19 SET ^%ZTSK(ZTSK,0,"ABPA(","UPAMT")=ABPA("UPAMT")
+20 SET ^%ZTSK(ZTSK,0,"ABPA(","TRAN")=ABPA("TRAN")
+21 SET ^%ZTSK(ZTSK,0,"ABPA(","REF")=ABPA("REF")
+22 ;
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="START^ABPAAR1D"
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 UTILILIZATION 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,PRINTNOW
+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)'="ABPAAR1B"
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")
+10 IF $DATA(^%ZTSK(ZTSK,0,"ABPA(","UPAMT"))=1
SET ABPA("UPAMT")=^("UPAMT")
+11 IF $DATA(^%ZTSK(ZTSK,0,"ABPA(","TRAN"))=1
SET ABPA("TRAN")=^("TRAN")
+12 IF $DATA(^%ZTSK(ZTSK,0,"ABPA(","REF"))=1
SET ABPA("REF")=^("REF")
End DoDot:1
IF +ZTSK=0
QUIT
+13 WRITE !!!
KILL ABPA("IO")
FOR J=0:0
Begin DoDot:1
+14 KILL %IS,IOP
SET %IS="NP"
SET %IS("A")="Select PRINTER: "
DO ^%ZIS
+15 IF POP
QUIT
IF $EXTRACT(IOST,1)'="P"
Begin DoDot:2
+16 WRITE *7,?5,"<<< NOT A PRINTER DEVICE >>>"
End DoDot:2
QUIT
+17 SET ABPA("IO")=+IO
End DoDot:1
IF $DATA(ABPA("IO"))=1!(POP)
QUIT
+18 IF FOUND&($DATA(ABPA("IO"))=1)
WRITE !!
DO WAIT^DICD
GOTO START^ABPAAR1D
+19 GOTO ZTLEND
