- 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
