ASURM79P ; IHS/ITSC/LMH -PRINT S.A.M.S. REPORT 79 ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 79 Analysis of Issues
;to Program.
;^XTMP("ASUR","R79",AREA/STA,PROGRAM,SUB STATION,USER,ACCOUNT)
;*********************************************************************
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 79
Q ;WAR 5/21/99
I '$D(IO) D HOME^%ZIS
I '$D(DUZ(2)) W !,"Report must be run from Kernel option" Q
I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST
S ASUK("PTRSEL")=$G(ASUK("PTRSEL"))
I ASUK("PTRSEL")]"" G PSER
S ZTRTN="PSER^ASURM79P",ZTDESC="SAMS RPT 79" D O^ASUUZIS
I POP S IOP=$I D ^%ZIS Q
I ASUK(ASUK("PTR"),"Q") Q
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
D:'$D(^XTMP("ASUR","R79")) CMPT
D U^ASUUZIS
D SETHEADR ;Set header values
F S ASUX("ARST")=$O(^XTMP("ASUR","R79",$G(ASUX("ARST")))) Q:ASUX("ARST")="" D Q:$D(DUOUT)
.F D INITPGM S ASUX("PGM")=$O(^XTMP("ASUR","R79",ASUX("ARST"),$G(ASUX("PGM")))) Q:ASUX("PGM")="" D HEADER Q:$D(DUOUT) D Q:$D(DUOUT)
..F D NEWPAGE Q:$D(DUOUT) D INITSST S ASUX("SST")=$O(^XTMP("ASUR","R79",ASUX("ARST"),ASUX("PGM"),$G(ASUX("SST")))) Q:ASUX("SST")="" D Q:$D(DUOUT)
...D SST^ASULDIRR(ASUX("SST"))
...W !,ASUL(18,"SST")," - ",ASUL(18,"SST","NM")
...F D INITUSR D NEWPAGE Q:$D(DUOUT) S ASUX("USR")=$O(^XTMP("ASUR","R79",ASUX("ARST"),ASUX("PGM"),ASUX("SST"),$G(ASUX("USR")))) Q:ASUX("USR")="" D Q:$D(DUOUT)
....S ASUX("REQ")=ASUX("SST")_$E(ASUX("USR"),3,6)
....D USR^ASULDIRR(ASUX("USR")),REQ^ASULDIRR(ASUX("REQ"))
....W !,ASUL(20,"REQ")," - ",ASUL(19,"USR","NM")
....F D NEWPAGE Q:$D(DUOUT) S ASUX("ACC")=$O(^XTMP("ASUR","R79",ASUX("ARST"),ASUX("PGM"),ASUX("SST"),ASUX("USR"),$G(ASUX("ACC")))) Q:ASUX("ACC")="" S ASUX("DTA")=^(ASUX("ACC")) D NEWPAGE Q:$D(DUOUT) W !?4,$$ACC(ASUX("ACC")) D SETDATA
....D NEWPAGE Q:$D(DUOUT) W !?4,"USER TOT:"
....D OUT("USR")
....W ! Q
...D NEWPAGE Q:$D(DUOUT) W !,"SUB-STA TOT:"
...F ASUU(1)=0:0 S ASUU(1)=$O(ASUX("SST",ASUU(1))) Q:'ASUU(1) I ASUX("SST",ASUU(1))]"" F ASUU(2)=1:1:13 S ASUX("SS",ASUU(2))=$P(ASUX("SST",ASUU(1)),U,ASUU(2)) I ASUU(2)=13 D Q:$D(DUOUT)
....D NEWPAGE Q:$D(DUOUT) W !?4,$$ACC(ASUU(1))
....D OUT("SS")
...D NEWPAGE Q:$D(DUOUT) W !,"SUB ST TOT:"
...D OUT("SSU")
...W !!!!
..D NEWPAGE Q:$D(DUOUT) W !,"PROGRAM TOT:"
..F ASUU(1)=0:0 S ASUU(1)=$O(ASUX("PGM",ASUU(1))) Q:'ASUU(1) I ASUX("PGM",ASUU(1))]"" F ASUU(2)=1:1:13 S ASUX("US1",ASUU(2))=$P(ASUX("PGM",ASUU(1)),U,ASUU(2)) I ASUU(2)=13 D Q:$D(DUOUT)
...D NEWPAGE Q:$D(DUOUT) W !?4,$$ACC(ASUU(1))
...D OUT("US1")
..D NEWPAGE Q:$D(DUOUT) W !,"PROGRAM TOT:"
..D OUT("PGU")
..W !
D PAZ^ASUURHDR W @IOF D:$G(ASUK("PTRSEL"))']"" ^%ZISC ;Run output then quit
K ASUR,ASUX,POP,Y,ASUU,ASUC
F X=3:1:22 K ASUL(X) ;Clear Table Lookup fields
I $G(ASUK("PTRSEL"))']"" K ASUK
Q
NEWPAGE ;FF
I $Y+4>IOSL D HEADER
Q
INITSST ;Initialize counters for sub-station totals 1 and 2
;1,2,3,4,5,9 are accounts used by S.A.M.S.
F ASUU(0)=1,2,3,4,5,9 S ASUX("SST",ASUU(0))=""
K ASUX("SSU")
Q
INITPGM ;Initialize counters for program totals 1 and 2
F ASUU(0)=1,2,3,4,5,9 S ASUX("PGM",ASUU(0))=""
K ASUX("PGU")
Q
INITUSR ;Initialize counters for program totals 1 and 2
F ASUU(0)=1:1:13 S ASUX("USR",ASUU(0))=""
K ASUX("US1")
Q
ACC(X) ;Write account -extrinsic
S X=$S(X=1:"DRUGS",X=2:"MEDICA",X=3:"SUBSIS",X=4:"LABORA",X=5:"OF/ADM",X=9:"OTHER",1:"NF")
Q X
SETHEADR ;Set hdrs
;Hdr1
S ASU1(1)=" STOCK ISSUE VALUE ",ASU1(2)=" DIRECT ISSUE VALUE ",ASU1(3)=" TOTAL ISSUE VALUE ",ASU1(4)=" STOCK LINE ITEMS ",ASU1(5)="DIRECT ISS",ASU1(6)=" STOCK",ASU1(7)="DIRECT"
;Hdr2
S ASU2(1)="CM",ASU2(2)="Y-T-D",ASU2(3)="CM",ASU2(4)="Y-T-D",ASU2(5)="CM",ASU2(6)="Y-T-D",ASU2(7)="CM Y-T-D %OUT",ASU2(8)="LINE ITEMS",ASU2(9)="IS DOC",ASU2(10)="IS DOC"
;Hdr3
S ASU3(1)="CM Y-T-D",ASU3(2)="Y-T-D",ASU3(3)="Y-T-D"
Q
I ($D(ASUK("DT"))#10)'=1 D DATE^ASUUDATE
S ASUX("PG")=$G(ASUX("PG"))+1 D:ASUX("PG")>1 PAZ^ASUURHDR Q:$D(DUOUT) W @IOF
W !,"REPORT # 79 SUMMARY OF ISSUES TO PROGRAM",?60,ASUK("DT"),?120,"PAGE ",ASUX("PG"),!,"AREA NAME: ",ASUL(1,"AR","NM")
;Hdr1
D PGM^ASULDIRR(ASUX("PGM"))
W !,"PROGRAM ",ASUL(22,"PGM")," - ",ASUL(22,"PGM","NM"),!!!,"SUB-STA",?13,ASU1(1),?36,ASU1(2),?60,ASU1(3),?82,ASU1(4),?104,ASU1(5),?118,ASU1(6),?126,ASU1(7)
;Hdr2
W !?2,"USER",?20,ASU2(1),?29,ASU2(2),?41,ASU2(3),?52,ASU2(4),?65,ASU2(5),?73,ASU2(6),?84,"REQUESTED",?104,ASU2(8),?118,ASU2(9),?126,ASU2(10)
;Hdr3
W !?4,"ACCNT",?84,ASU2(7),?106,ASU3(1),?119,ASU3(2),?127,ASU3(3)
S:'$D(ASUR("LN")) $P(ASUR("LN"),"=",131)="=" W !!,ASUR("LN")
Q
SETDATA ;Set DATA line
S ASUX("FLD",1)=$FN($P(ASUX("DTA"),U,2),"",0)
S ASUX("FLD",2)=$FN($P(ASUX("DTA"),U,3),"",0)
S ASUX("FLD",3)=$FN($P(ASUX("DTA"),U,5),"",0)
S ASUX("FLD",4)=$FN($P(ASUX("DTA"),U,6),"",0)
S ASUX("FLD",5)=$FN(($P(ASUX("DTA"),U,2)+$P(ASUX("DTA"),U,5)),"",0)
S ASUX("FLD",6)=$FN(($P(ASUX("DTA"),U,3)+$P(ASUX("DTA"),U,6)),"",0)
S ASUX("FLD",7)=$FN(($P(ASUX("DTA"),U,7)+$P(ASUX("DTA"),U,11)),"",0)
S ASUX("FLD",8)=$FN(($P(ASUX("DTA"),U,8)+$P(ASUX("DTA"),U,12)),"",0)
I +$P(ASUX("DTA"),U,8)>0 D
.S X=($P(ASUX("DTA"),U,15)/+$P(ASUX("DTA"),U,8))*100
.S ASUX("FLD",9)=$FN(X,"",0)
E D
.S ASUX("FLD",9)=0
S ASUX("FLD",10)=$FN($P(ASUX("DTA"),U,19),"",0)
S ASUX("FLD",11)=$FN($P(ASUX("DTA"),U,20),"",0)
S ASUX("FLD",12)=$FN(($P(ASUX("DTA"),U,10)+$P(ASUX("DTA"),U,14)),"",0)
S ASUX("FLD",13)=$FN($P(ASUX("DTA"),U,22),"",0)
;
UT ;Set user totals
F ASUU(0)=1:1:13 S ASUX("USR",ASUU(0))=$G(ASUX("USR",ASUU(0)))+ASUX("FLD",ASUU(0))
;
SST ;Set totals for sub-stations
F ASUU(0)=1:1:13 S $P(ASUX("SST",ASUX("ACC")),U,ASUU(0))=$P($G(ASUX("SST",ASUX("ACC"))),U,ASUU(0))+ASUX("FLD",ASUU(0))
F ASUU(0)=1:1:13 S ASUX("SSU",ASUU(0))=$G(ASUX("SSU",ASUU(0)))+ASUX("FLD",ASUU(0))
;
PT ;Set program totals
F ASUU(0)=1:1:13 S $P(ASUX("PGM",ASUX("ACC")),U,ASUU(0))=$P($G(ASUX("PGM",ASUX("ACC"))),U,ASUU(0))+ASUX("FLD",ASUU(0))
F ASUU(0)=1:1:13 S ASUX("PGU",ASUU(0))=$G(ASUX("PGU",ASUU(0)))+ASUX("FLD",ASUU(0))
;
;Print data line
D OUT("FLD")
Q
;
OUT(X) ;EP; -Print Data line and subtotals for user/sub-station/program
;Formal parameter is X (NAME OF COUNTER)
;Actual parameter will be 1 of the following:
;"USR" for user total
;"SS" for sub-station total
;"SSU" for 2nd sub-station total in form of user total
;"PGM" for program total
;"PGU" for 2nd program total in form of user total
;"FLD" for data line
W ?15,$J($FN(ASUX(X,1),","),7)
W ?25,$J($FN(ASUX(X,2),","),9)
W ?36,$J($FN(ASUX(X,3),","),7)
W ?48,$J($FN(ASUX(X,4),","),9)
W ?60,$J($FN(ASUX(X,5),","),7)
W ?70,$J($FN(ASUX(X,6),","),9)
W ?82,$J($FN(ASUX(X,7),","),4)
W ?89,$J($FN(ASUX(X,8),","),6)
W ?97,$J(ASUX(X,9),4,1)
W ?103,$J($FN(ASUX(X,10),","),5)
W ?108,$J($FN(ASUX(X,11),","),7)
W ?118,$J($FN(ASUX(X,12),","),6)
W ?126,$J($FN(ASUX(X,13),","),6)
Q
CMPT ;EP ;SORT
K ^XTMP("ASUR","R79")
S ^XTMP("ASUR","R79",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
F ASUMY("E#","REQ")=0:0 S ASUMY("E#","REQ")=$O(^ASUMY(ASUMY("E#","REQ"))) Q:ASUMY("E#","REQ")'?1N.N D
.F ASUMY("E#","SSA")=0:0 S ASUMY("E#","SSA")=$O(^ASUMY(ASUMY("E#","REQ"),1,ASUMY("E#","SSA"))) Q:ASUMY("E#","SSA")'?1N.N D
..F ASUMY("E#","ACC")=0:0 S ASUMY("E#","ACC")=$O(^ASUMY(ASUMY("E#","REQ"),1,ASUMY("E#","SSA"),1,ASUMY("E#","ACC"))) Q:ASUMY("E#","ACC")'?1N.N D
...K ASUF("OK")
...D READ^ASUMYDIO
...F ASUU(0)=1:1:22 I $P(ASUMY(0),U,ASUU(0)) S ASUF("OK")=1
...Q:'$D(ASUF("OK"))
...S ASUX("SST")=$E(ASUMY("E#","REQ"),1,5),ASUX("USR")=ASUL(1,"AR","AP")_$E(ASUMY("E#","REQ"),6,9)
...S ASUMY=$G(^XTMP("ASUR","R79","*",ASUMY("E#","PGM"),ASUX("SST"),ASUX("USR"),ASUMY("E#","ACC"))) D
....I ASUMY="" S ASUMY=ASUMY(0) Q
....F ASUX=1:1:22 S $P(ASUMY,U,ASUX)=$P(ASUMY,U,ASUX)+$P(ASUMY(0),U,ASUX)
...S ^XTMP("ASUR","R79","*",ASUMY("E#","PGM"),ASUX("SST"),ASUX("USR"),ASUMY("E#","ACC"))=U_ASUMY
K ASUX,ASUMY,ASU1,ASU2,ASU3,ASUF("OK")
I $G(ASUP("TYP"))="" K ASUK,ASUW
Q
ASURM79P ; IHS/ITSC/LMH -PRINT S.A.M.S. REPORT 79 ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 79 Analysis of Issues
+3 ;to Program.
+4 ;^XTMP("ASUR","R79",AREA/STA,PROGRAM,SUB STATION,USER,ACCOUNT)
+5 ;*********************************************************************
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 79
+1 ;WAR 5/21/99
QUIT
+2 IF '$DATA(IO)
DO HOME^%ZIS
+3 IF '$DATA(DUZ(2))
WRITE !,"Report must be run from Kernel option"
QUIT
+4 IF '$DATA(ASUL(1,"AR","AP"))
DO SETAREA^ASULARST
+5 SET ASUK("PTRSEL")=$GET(ASUK("PTRSEL"))
+6 IF ASUK("PTRSEL")]""
GOTO PSER
+7 SET ZTRTN="PSER^ASURM79P"
SET ZTDESC="SAMS RPT 79"
DO O^ASUUZIS
+8 IF POP
SET IOP=$IO
DO ^%ZIS
QUIT
+9 IF ASUK(ASUK("PTR"),"Q")
QUIT
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
+1 IF '$DATA(^XTMP("ASUR","R79"))
DO CMPT
+2 DO U^ASUUZIS
+3 ;Set header values
DO SETHEADR
+4 FOR
SET ASUX("ARST")=$ORDER(^XTMP("ASUR","R79",$GET(ASUX("ARST"))))
IF ASUX("ARST")=""
QUIT
Begin DoDot:1
+5 FOR
DO INITPGM
SET ASUX("PGM")=$ORDER(^XTMP("ASUR","R79",ASUX("ARST"),$GET(ASUX("PGM"))))
IF ASUX("PGM")=""
QUIT
DO HEADER
IF $DATA(DUOUT)
QUIT
Begin DoDot:2
+6 FOR
DO NEWPAGE
IF $DATA(DUOUT)
QUIT
DO INITSST
SET ASUX("SST")=$ORDER(^XTMP("ASUR","R79",ASUX("ARST"),ASUX("PGM"),$GET(ASUX("SST"))))
IF ASUX("SST")=""
QUIT
Begin DoDot:3
+7 DO SST^ASULDIRR(ASUX("SST"))
+8 WRITE !,ASUL(18,"SST")," - ",ASUL(18,"SST","NM")
+9 FOR
DO INITUSR
DO NEWPAGE
IF $DATA(DUOUT)
QUIT
SET ASUX("USR")=$ORDER(^XTMP("ASUR","R79",ASUX("ARST"),ASUX("PGM"),ASUX("SST"),$GET(ASUX("USR"))))
IF ASUX("USR")=""
QUIT
Begin DoDot:4
+10 SET ASUX("REQ")=ASUX("SST")_$EXTRACT(ASUX("USR"),3,6)
+11 DO USR^ASULDIRR(ASUX("USR"))
DO REQ^ASULDIRR(ASUX("REQ"))
+12 WRITE !,ASUL(20,"REQ")," - ",ASUL(19,"USR","NM")
+13 FOR
DO NEWPAGE
IF $DATA(DUOUT)
QUIT
SET ASUX("ACC")=$ORDER(^XTMP("ASUR","R79",ASUX("ARST"),ASUX("PGM"),ASUX("SST"),ASUX("USR"),$GET(ASUX("ACC"))))
IF ASUX("ACC")=""
QUIT
SET ASUX("DTA")=^(ASUX("ACC"))
DO NEWPAGE
IF $DATA(DUOUT)
QUIT
WRITE !?4,$$ACC(ASUX("ACC"))
DO SETDATA
+14 DO NEWPAGE
IF $DATA(DUOUT)
QUIT
WRITE !?4,"USER TOT:"
+15 DO OUT("USR")
+16 WRITE !
QUIT
End DoDot:4
IF $DATA(DUOUT)
QUIT
+17 DO NEWPAGE
IF $DATA(DUOUT)
QUIT
WRITE !,"SUB-STA TOT:"
+18 FOR ASUU(1)=0:0
SET ASUU(1)=$ORDER(ASUX("SST",ASUU(1)))
IF 'ASUU(1)
QUIT
IF ASUX("SST",ASUU(1))]""
FOR ASUU(2)=1:1:13
SET ASUX("SS",ASUU(2))=$PIECE(ASUX("SST",ASUU(1)),U,ASUU(2))
IF ASUU(2)=13
Begin DoDot:4
+19 DO NEWPAGE
IF $DATA(DUOUT)
QUIT
WRITE !?4,$$ACC(ASUU(1))
+20 DO OUT("SS")
End DoDot:4
IF $DATA(DUOUT)
QUIT
+21 DO NEWPAGE
IF $DATA(DUOUT)
QUIT
WRITE !,"SUB ST TOT:"
+22 DO OUT("SSU")
+23 WRITE !!!!
End DoDot:3
IF $DATA(DUOUT)
QUIT
+24 DO NEWPAGE
IF $DATA(DUOUT)
QUIT
WRITE !,"PROGRAM TOT:"
+25 FOR ASUU(1)=0:0
SET ASUU(1)=$ORDER(ASUX("PGM",ASUU(1)))
IF 'ASUU(1)
QUIT
IF ASUX("PGM",ASUU(1))]""
FOR ASUU(2)=1:1:13
SET ASUX("US1",ASUU(2))=$PIECE(ASUX("PGM",ASUU(1)),U,ASUU(2))
IF ASUU(2)=13
Begin DoDot:3
+26 DO NEWPAGE
IF $DATA(DUOUT)
QUIT
WRITE !?4,$$ACC(ASUU(1))
+27 DO OUT("US1")
End DoDot:3
IF $DATA(DUOUT)
QUIT
+28 DO NEWPAGE
IF $DATA(DUOUT)
QUIT
WRITE !,"PROGRAM TOT:"
+29 DO OUT("PGU")
+30 WRITE !
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
IF $DATA(DUOUT)
QUIT
+31 ;Run output then quit
DO PAZ^ASUURHDR
WRITE @IOF
IF $GET(ASUK("PTRSEL"))']""
DO ^%ZISC
+32 KILL ASUR,ASUX,POP,Y,ASUU,ASUC
+33 ;Clear Table Lookup fields
FOR X=3:1:22
KILL ASUL(X)
+34 IF $GET(ASUK("PTRSEL"))']""
KILL ASUK
+35 QUIT
NEWPAGE ;FF
+1 IF $Y+4>IOSL
DO HEADER
+2 QUIT
INITSST ;Initialize counters for sub-station totals 1 and 2
+1 ;1,2,3,4,5,9 are accounts used by S.A.M.S.
+2 FOR ASUU(0)=1,2,3,4,5,9
SET ASUX("SST",ASUU(0))=""
+3 KILL ASUX("SSU")
+4 QUIT
INITPGM ;Initialize counters for program totals 1 and 2
+1 FOR ASUU(0)=1,2,3,4,5,9
SET ASUX("PGM",ASUU(0))=""
+2 KILL ASUX("PGU")
+3 QUIT
INITUSR ;Initialize counters for program totals 1 and 2
+1 FOR ASUU(0)=1:1:13
SET ASUX("USR",ASUU(0))=""
+2 KILL ASUX("US1")
+3 QUIT
ACC(X) ;Write account -extrinsic
+1 SET X=$SELECT(X=1:"DRUGS",X=2:"MEDICA",X=3:"SUBSIS",X=4:"LABORA",X=5:"OF/ADM",X=9:"OTHER",1:"NF")
+2 QUIT X
SETHEADR ;Set hdrs
+1 ;Hdr1
+2 SET ASU1(1)=" STOCK ISSUE VALUE "
SET ASU1(2)=" DIRECT ISSUE VALUE "
SET ASU1(3)=" TOTAL ISSUE VALUE "
SET ASU1(4)=" STOCK LINE ITEMS "
SET ASU1(5)="DIRECT ISS"
SET ASU1(6)=" STOCK"
SET ASU1(7)="DIRECT"
+3 ;Hdr2
+4 SET ASU2(1)="CM"
SET ASU2(2)="Y-T-D"
SET ASU2(3)="CM"
SET ASU2(4)="Y-T-D"
SET ASU2(5)="CM"
SET ASU2(6)="Y-T-D"
SET ASU2(7)="CM Y-T-D %OUT"
SET ASU2(8)="LINE ITEMS"
SET ASU2(9)="IS DOC"
SET ASU2(10)="IS DOC"
+5 ;Hdr3
+6 SET ASU3(1)="CM Y-T-D"
SET ASU3(2)="Y-T-D"
SET ASU3(3)="Y-T-D"
+7 QUIT
+1 IF ($DATA(ASUK("DT"))#10)'=1
DO DATE^ASUUDATE
+2 SET ASUX("PG")=$GET(ASUX("PG"))+1
IF ASUX("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
WRITE @IOF
+3 WRITE !,"REPORT # 79 SUMMARY OF ISSUES TO PROGRAM",?60,ASUK("DT"),?120,"PAGE ",ASUX("PG"),!,"AREA NAME: ",ASUL(1,"AR","NM")
+4 ;Hdr1
+5 DO PGM^ASULDIRR(ASUX("PGM"))
+6 WRITE !,"PROGRAM ",ASUL(22,"PGM")," - ",ASUL(22,"PGM","NM"),!!!,"SUB-STA",?13,ASU1(1),?36,ASU1(2),?60,ASU1(3),?82,ASU1(4),?104,ASU1(5),?118,ASU1(6),?126,ASU1(7)
+7 ;Hdr2
+8 WRITE !?2,"USER",?20,ASU2(1),?29,ASU2(2),?41,ASU2(3),?52,ASU2(4),?65,ASU2(5),?73,ASU2(6),?84,"REQUESTED",?104,ASU2(8),?118,ASU2(9),?126,ASU2(10)
+9 ;Hdr3
+10 WRITE !?4,"ACCNT",?84,ASU2(7),?106,ASU3(1),?119,ASU3(2),?127,ASU3(3)
+11 IF '$DATA(ASUR("LN"))
SET $PIECE(ASUR("LN"),"=",131)="="
WRITE !!,ASUR("LN")
+12 QUIT
SETDATA ;Set DATA line
+1 SET ASUX("FLD",1)=$FNUMBER($PIECE(ASUX("DTA"),U,2),"",0)
+2 SET ASUX("FLD",2)=$FNUMBER($PIECE(ASUX("DTA"),U,3),"",0)
+3 SET ASUX("FLD",3)=$FNUMBER($PIECE(ASUX("DTA"),U,5),"",0)
+4 SET ASUX("FLD",4)=$FNUMBER($PIECE(ASUX("DTA"),U,6),"",0)
+5 SET ASUX("FLD",5)=$FNUMBER(($PIECE(ASUX("DTA"),U,2)+$PIECE(ASUX("DTA"),U,5)),"",0)
+6 SET ASUX("FLD",6)=$FNUMBER(($PIECE(ASUX("DTA"),U,3)+$PIECE(ASUX("DTA"),U,6)),"",0)
+7 SET ASUX("FLD",7)=$FNUMBER(($PIECE(ASUX("DTA"),U,7)+$PIECE(ASUX("DTA"),U,11)),"",0)
+8 SET ASUX("FLD",8)=$FNUMBER(($PIECE(ASUX("DTA"),U,8)+$PIECE(ASUX("DTA"),U,12)),"",0)
+9 IF +$PIECE(ASUX("DTA"),U,8)>0
Begin DoDot:1
+10 SET X=($PIECE(ASUX("DTA"),U,15)/+$PIECE(ASUX("DTA"),U,8))*100
+11 SET ASUX("FLD",9)=$FNUMBER(X,"",0)
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET ASUX("FLD",9)=0
End DoDot:1
+14 SET ASUX("FLD",10)=$FNUMBER($PIECE(ASUX("DTA"),U,19),"",0)
+15 SET ASUX("FLD",11)=$FNUMBER($PIECE(ASUX("DTA"),U,20),"",0)
+16 SET ASUX("FLD",12)=$FNUMBER(($PIECE(ASUX("DTA"),U,10)+$PIECE(ASUX("DTA"),U,14)),"",0)
+17 SET ASUX("FLD",13)=$FNUMBER($PIECE(ASUX("DTA"),U,22),"",0)
+18 ;
UT ;Set user totals
+1 FOR ASUU(0)=1:1:13
SET ASUX("USR",ASUU(0))=$GET(ASUX("USR",ASUU(0)))+ASUX("FLD",ASUU(0))
+2 ;
SST ;Set totals for sub-stations
+1 FOR ASUU(0)=1:1:13
SET $PIECE(ASUX("SST",ASUX("ACC")),U,ASUU(0))=$PIECE($GET(ASUX("SST",ASUX("ACC"))),U,ASUU(0))+ASUX("FLD",ASUU(0))
+2 FOR ASUU(0)=1:1:13
SET ASUX("SSU",ASUU(0))=$GET(ASUX("SSU",ASUU(0)))+ASUX("FLD",ASUU(0))
+3 ;
PT ;Set program totals
+1 FOR ASUU(0)=1:1:13
SET $PIECE(ASUX("PGM",ASUX("ACC")),U,ASUU(0))=$PIECE($GET(ASUX("PGM",ASUX("ACC"))),U,ASUU(0))+ASUX("FLD",ASUU(0))
+2 FOR ASUU(0)=1:1:13
SET ASUX("PGU",ASUU(0))=$GET(ASUX("PGU",ASUU(0)))+ASUX("FLD",ASUU(0))
+3 ;
+4 ;Print data line
+5 DO OUT("FLD")
+6 QUIT
+7 ;
OUT(X) ;EP; -Print Data line and subtotals for user/sub-station/program
+1 ;Formal parameter is X (NAME OF COUNTER)
+2 ;Actual parameter will be 1 of the following:
+3 ;"USR" for user total
+4 ;"SS" for sub-station total
+5 ;"SSU" for 2nd sub-station total in form of user total
+6 ;"PGM" for program total
+7 ;"PGU" for 2nd program total in form of user total
+8 ;"FLD" for data line
+9 WRITE ?15,$JUSTIFY($FNUMBER(ASUX(X,1),","),7)
+10 WRITE ?25,$JUSTIFY($FNUMBER(ASUX(X,2),","),9)
+11 WRITE ?36,$JUSTIFY($FNUMBER(ASUX(X,3),","),7)
+12 WRITE ?48,$JUSTIFY($FNUMBER(ASUX(X,4),","),9)
+13 WRITE ?60,$JUSTIFY($FNUMBER(ASUX(X,5),","),7)
+14 WRITE ?70,$JUSTIFY($FNUMBER(ASUX(X,6),","),9)
+15 WRITE ?82,$JUSTIFY($FNUMBER(ASUX(X,7),","),4)
+16 WRITE ?89,$JUSTIFY($FNUMBER(ASUX(X,8),","),6)
+17 WRITE ?97,$JUSTIFY(ASUX(X,9),4,1)
+18 WRITE ?103,$JUSTIFY($FNUMBER(ASUX(X,10),","),5)
+19 WRITE ?108,$JUSTIFY($FNUMBER(ASUX(X,11),","),7)
+20 WRITE ?118,$JUSTIFY($FNUMBER(ASUX(X,12),","),6)
+21 WRITE ?126,$JUSTIFY($FNUMBER(ASUX(X,13),","),6)
+22 QUIT
CMPT ;EP ;SORT
+1 KILL ^XTMP("ASUR","R79")
+2 SET ^XTMP("ASUR","R79",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
+3 FOR ASUMY("E#","REQ")=0:0
SET ASUMY("E#","REQ")=$ORDER(^ASUMY(ASUMY("E#","REQ")))
IF ASUMY("E#","REQ")'?1N.N
QUIT
Begin DoDot:1
+4 FOR ASUMY("E#","SSA")=0:0
SET ASUMY("E#","SSA")=$ORDER(^ASUMY(ASUMY("E#","REQ"),1,ASUMY("E#","SSA")))
IF ASUMY("E#","SSA")'?1N.N
QUIT
Begin DoDot:2
+5 FOR ASUMY("E#","ACC")=0:0
SET ASUMY("E#","ACC")=$ORDER(^ASUMY(ASUMY("E#","REQ"),1,ASUMY("E#","SSA"),1,ASUMY("E#","ACC")))
IF ASUMY("E#","ACC")'?1N.N
QUIT
Begin DoDot:3
+6 KILL ASUF("OK")
+7 DO READ^ASUMYDIO
+8 FOR ASUU(0)=1:1:22
IF $PIECE(ASUMY(0),U,ASUU(0))
SET ASUF("OK")=1
+9 IF '$DATA(ASUF("OK"))
QUIT
+10 SET ASUX("SST")=$EXTRACT(ASUMY("E#","REQ"),1,5)
SET ASUX("USR")=ASUL(1,"AR","AP")_$EXTRACT(ASUMY("E#","REQ"),6,9)
+11 SET ASUMY=$GET(^XTMP("ASUR","R79","*",ASUMY("E#","PGM"),ASUX("SST"),ASUX("USR"),ASUMY("E#","ACC")))
Begin DoDot:4
+12 IF ASUMY=""
SET ASUMY=ASUMY(0)
QUIT
+13 FOR ASUX=1:1:22
SET $PIECE(ASUMY,U,ASUX)=$PIECE(ASUMY,U,ASUX)+$PIECE(ASUMY(0),U,ASUX)
End DoDot:4
+14 SET ^XTMP("ASUR","R79","*",ASUMY("E#","PGM"),ASUX("SST"),ASUX("USR"),ASUMY("E#","ACC"))=U_ASUMY
End DoDot:3
End DoDot:2
End DoDot:1
+15 KILL ASUX,ASUMY,ASU1,ASU2,ASU3,ASUF("OK")
+16 IF $GET(ASUP("TYP"))=""
KILL ASUK,ASUW
+17 QUIT
