ASURO26A ; IHS/ITSC/LMH -CUPBOARD STOCK BIN LABLES ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 26A, Cupboard Stock Bin Labels
;Report.
Q ;WAR 5/21/99
K ^XTMP("ASUR","R26A")
S ^XTMP("ASUR","R26A",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
D SETAREA^ASULARST
K ASUF("QU")
D DIR
G EXIT
DIR ;Menu
;
F ASU1(10)=1:1:3 W !,ASU1(10)," ",$P($T(@ASU1(10)),";",3) I ASU1(10)=3 D S:X["^" ASUF("QU")=1 Q
.S DIR(0)="L^1:3^S ASUV(""RP26"")=Y",DIR("A")="ENTER SELECTION "
.W !
.D ^DIR
Q:$D(ASUF("QU"))
K ASUU("SST")
D SST I $D(ASUF("QU")) K ASUF("QU") Q
D USR I $D(ASUF("QU")) K ASUF("QU") Q
;
Q ;Queue
S ZRTN="LIST^ASURO26A"
S ASUF("NOQUE")=1
K IO("Q"),%ZIS,IOP S %ZIS="QM" D ^%ZIS Q:POP!('$D(IO("Q")))
K ZTDTH,ZTSAVE,ZTSK S ZTIO=ION
F ASU1="ASUX(","ASUU(","ASUK(","ASUV(","DUZ(" S ZTSAVE(ASU1)=""
D ^%ZTLOAD W !,"Report Queued.."
I POP!($D(IO("Q"))) K ASUF("QU") D COMPUTE Q
D COMPUTE G LIST
COMPUTE ;
S ASUNW(4)=ASUV("RP26")
F ASUNW(0)=1:1:$L(ASUNW(4),",")-1 S ASUTG=$P(ASUNW(4),",",ASUNW(0)) D A0
Q
LIST ;EP ;Taskman Entry Point
D HED,A1
EXIT ;
I $D(ASUNW),'$D(^XTMP("ASUR","R26A")) U IO(0) W !!,"******** NO DATA FOUND *********"
;
F X=10:1:21,29 K ASU1(X)
K ASUF,ASUR,ASUNW,ASUTG,ASUV,ASUT,DIR,ZRTN,ASUMS,ASUMX,ASUMB
BYE ;
K ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17),ASU1(18),ASU1(19),ASU1(20)
K ASUC,ASUF,ASUFB,ASUMU,ASU1,ASUF("NOQUE"),ASUMX,ASUMS,ASUMB
K ASUL,ASUR,ASUT,ASUTG,ASUX,DIR,ZTDESC,ZTIO,ZTRTN
K ^XTMP("ASUR","R26A")
K ASUT,ASUV,ASUC,ASUF("NOQUE"),ASUE
D PAZ^ASUURHDR W @IOF D ^%ZISC
Q
HED ;Header vars
S ASUX(0)=$P($T(@ASUTG),";",3),ASUX(1)="IND # ",ASUX(2)="U/I: ",ASUX(3)="USER LEVEL",ASUX(4)="AR ",ASUX(5)="ST ",ASUX(6)="S-ST ",ASUX(7)="U-C "
Q
1 ;;CUPBOARD STOCK BIN LABELS -ALPHA SEQ BY SUB STATION AND USER
2 ;;CUPBOARD STOCK BIN LABLES -ALPHA SEQ BY CATEGORY
3 ;;CUPBOARD STOCK BIN LABLES -INDEX SEQ
A0 ;
S X=$O(ASUU("SST","")) Q:X']""
I X="*ALL*" D
.S ASUX("STA")=ASUL(1,"AR","AP")_"000"
.F S ASUX("STA")=$O(^ASUMK(ASUX("STA"))) Q:$E(ASUX("STA"),1,2)'=ASUL(1,"AR","AP") D USER
E D
.S ASUX("STA")=ASUL(2,"STA","E#")
.F S ASUX("STA")=$O(ASUU("SST",ASUX("STA"))) Q:ASUX("STA")']"" D USER
K ASUMK,ASUMX,ASUMS,ASUC,ASUU,ASUC,ASUX
Q
USER ;Process Users in Sub Station
S ASUMK("E#","STA")=ASUX("STA")
S X=$O(ASUU("USR","")) Q:X']""
I X="*ALL*" D
.S ASUX("USR")=ASUL(1,"AR","AP")_"0000"
.F S ASUX("USR")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUX("USR"))) Q:ASUX("USR")'?1N.N D BUILD
E D
.S ASUX("USR")=""
.F S ASUX("USR")=$O(ASUU("USR",ASUMK("E#","STA"),ASUX("USR"))) Q:ASUX("USR")']"" D BUILD
Q
BUILD ;Process Indexs in User
S ASUMK("E#","REQ")=ASUX("USR")
S ASUMK("E#","IDX")=0
F ASUC("IDX")=1:1 S ASUMK("E#","IDX")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"))) Q:ASUMK("E#","IDX")'?1N.N D
.W:ASUC("IDX")#20=0 "."
.D READ^ASUMKBIO
.S ASUMS("E#","STA")=$G(ASUL(1,"AR","STA1"))
.S:ASUMS("E#","STA")']"" ASUMS("E#","STA")=ASUMK("E#","STA")
.D DIS^ASUMDIRM(ASUMS("E#","STA")) I Y<0 D
..S ASUMS("E#","STA")=$O(^ASUMS("C",ASUMK("E#","IDX"),""))
.I '$D(^ASUMS("C",ASUMK("E#","IDX"),ASUMS("E#","STA"))) D
..S ASUMS("E#","STA")=$O(^ASUMS("C",ASUMK("E#","IDX"),""))
.I ASUMS("E#","STA")']"" D Q
..W *7,!,"*** ERROR *** -Unable to find Station for Index # ",$E(ASUMK("E#","IDX"),3,8)," for to Sub Station ",$E(ASUMK("E#","STA"),3,5)
.S ASUMS(2)=^ASUMS(ASUMS("E#","STA"),1,ASUMK("E#","IDX"),2)
.S ASUMX(0)=^ASUMX(ASUMK("E#","IDX"),0)
.S ASUMS("EOQ","TP")=$P(ASUMS(2),U,5)
.S ASUMS("SLC")=$P(ASUMS(2),U)
.S ASUMX("ACC")=$P(ASUMX(0),U,6)
.S ASUMX("CAT")=$P(ASUMX(0),U,8)
.S ASUMX("DESC",1)=$E($P(ASUMX(0),U,2),1,30)
.S ASUMX("DESC",2)=$E($P(ASUMX(0),U,2),31,60)
.S ASUX("ACCG")=$S(ASUMX("ACC")=1:1,ASUMX("ACC")=3:3,1:4)
.S ASUX("SLC")=$S(ASUMS("SLC")="H":"H",ASUMS("SLC")="R":"R",1:"Z")
.S ASUX("CAT")=$S(+ASUV("RP26")=2:ASUMX("CAT"),1:"*")
.S:ASUX("CAT")']"" ASUX("CAT")="*"
.S ASUX("IDX")=$S(+ASUV("RP26")=3:ASUMX("IDX"),1:ASUMX("DESC",1))
.S X=$E(ASUMX("IDX"),1,5)_"."_$E(ASUMX("IDX"),6,6)_U_ASUMX("AR U/I")_U_ASUMX("DESC",1)
.S X=X_U_ASUMX("DESC",2)_U_ASUMK("ULQTY")_U_ASUL(1,"AR","AP")_U_ASUMS("E#","STA")_U_ASUMK("SST")_U_ASUMK("USR")
.S ^XTMP("ASUR","R26A",ASUX("STA"),ASUX("USR"),ASUX("ACCG"),ASUX("SLC"),ASUX("CAT"),ASUX("IDX"))=X
.K X
Q
A1 ;
I '$D(^XTMP("ASUR","R26A")) Q
;Print initial header
U IO
K ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17),ASU1(18),ASU1(19),ASU1(20)
S ASU1(11)=""
F S ASU1(11)=$O(^XTMP("ASUR","R26A",ASU1(11))) Q:ASU1(11)="" D
.S ASU1(12)="",ASU2(2)=0
.F S ASU1(12)=$O(^XTMP("ASUR","R26A",ASU1(11),ASU1(12))) Q:ASU1(12)="" D S ASU2(2)=1
..S ASU1(13)="",ASU2(3)=0
..F S ASU1(13)=$O(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13))) Q:ASU1(13)="" D S ASU2(3)=1
...S ASU1(14)="",ASU2(4)=0
...F S ASU1(14)=$O(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14))) Q:ASU1(14)="" D S ASU2(4)=1
....S ASU1(15)="",ASU2(5)=0
....F S ASU1(15)=$O(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15))) Q:ASU1(15)="" D SLC S ASU2(5)=1
....I ASU2(6) D NEWPAGE Q
....S ASU2(5)=0 Q
...I ASU2(5) D NEWPAGE Q
...S ASU2(4)=0 Q
..I ASU2(4) D NEWPAGE Q
..S ASU2(3)=0 Q
.I ASU2(3) D NEWPAGE Q
.S ASU2(2)=0 Q
I ASU2(2) D NEWPAGE Q
Q
SLC ;Order on ASU1(16)...it will be in form STORAGE LOCATION H,R,or *
S ASU1(16)="",ASU2(6)=0
F S ASU1(16)=$O(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16))) Q:ASU1(16)="" D S ASU2(6)=1
.S ASU1(17)="",ASU2(7)=0
.F S ASU1(17)=$O(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17))) Q:ASU1(17)="" D S ASU2(7)=1
..W !,"LABELS FOR USER ",ASU1(14),!?11,"ACCOUNT ",ASU1(15)
..W !?11,"LOCATION ",$S(ASU1(16)="Z":"",1:ASU1(16)),!?11,"CATEGORY ",$S(ASU1(17)="*":"",1:ASU1(17)),!!
..S ASU1(18)="",ASU2(8)=0
..F D LOOP Q:ASU1(18)']""
.I ASU2(8) D NEWPAGE Q
.S ASU2(7)=0 Q
I ASU2(7) D NEWPAGE Q
S ASU2(6)=0 Q
LOOP ;
S ASU1(21)=0
F ASU1(19)=1:1:3 D I ASU2(8) D COLUMN
.S ASU2(9)=0
.F S ASU1(18)=$O(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17),ASU1(18))) S:ASU1(18)="" ASU2(9)=1 D Q:ASU2(9)
..Q:ASU2(9)
..S ASU1(21)=ASU1(21)+1,ASU2(8)=1
..S ASUF("BK",ASU1(21))=1
..S ASUT(0)=^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17),ASU1(18))
..F ASU1(20)=1:1:9 S ASUC(ASU1(21),ASU1(20))=$P(ASUT(0),U,ASU1(20))
..S:ASU1(21)=3 ASU2(9)=1
.I ASU1(21)<3 F S ASU1(21)=ASU1(21)+1 D BLANK Q:ASU1(21)=3
.S ASU1(19)=3
Q
BLANK ;blank out one labels worth of print fields
S ASUF("BK",ASU1(21))=0
F ASU1(20)=1:1:9 S ASUC(ASU1(21),ASU1(20))=""
Q
NEWPAGE ;Form feed code
Q
D PAZ^ASUURHDR Q:$D(DUOUT)
W @IOF
Q
COLUMN ;Display columns
W !,ASUX(1),ASUC(1,1),?15,ASUX(2),ASUC(1,2),?24,ASUX(3)
I ASUF("BK",2) W ?41,ASUX(1),ASUC(2,1),?55,ASUX(2),ASUC(2,2),?64,ASUX(3)
I ASUF("BK",3) W ?81,ASUX(1),ASUC(3,1),?95,ASUX(2),ASUC(3,2),?104,ASUX(3)
W !,ASUC(1,3)
I ASUF("BK",2) W ?41,ASUC(2,3)
I ASUF("BK",3) W ?81,ASUC(3,3)
W !,ASUC(1,4),?37,ASUC(1,5)
I ASUF("BK",2) W ?41,ASUC(2,4),?73,ASUC(2,5)
I ASUF("BK",3) W ?81,ASUC(3,4),?115,ASUC(3,5)
W !,ASUX(4),ASUC(1,6),?7,ASUX(5),ASUC(1,7),?13,ASUX(6),ASUC(1,8),?21,ASUX(7),ASUC(1,9)
I ASUF("BK",2) W ?41,ASUX(4),ASUC(2,6),?51,ASUX(5),ASUC(2,7),?57,ASUX(6),ASUC(2,8),?65,ASUX(7),ASUC(2,9)
I ASUF("BK",3) W ?81,ASUX(4),ASUC(3,6),?87,ASUX(5),ASUC(3,7),?93,ASUX(6),ASUC(3,8),?101,ASUX(7),ASUC(3,9)
W !!
S:'$D(ASUC("LAB")) ASUC("LAB")=0 S ASUC("LAB")=ASUC("LAB")+1 I ASUC("LAB")=9 S ASUC("LAB")=0 D NEWPAGE
Q
SST ;EP ;
;********************************************************
;Reports are running by sub-station. A futher breakdown
;is now determined. Run ALL or SELECTED
;This routine will return a ASUU("SST",E#) that holds the entry numbers
;*********************************************************
K ASUU("SST"),DIR S ASUX(32)="GROUP SUB-TOTALED BY: NO SUB-TOTALS"
S DIR(0)="S^1:Print 'ALL' sub-stations;2:Print 'SELECTED' sub-stations",DIR("A")="Sub-Station Print Criteria"
D ^DIR G:Y="^" KILSS
I Y=1 D
.S ASUX(31)="GROUP RESTRICTED TO ALL SUB-STATIONS"
.S ASUU("SST","*ALL*")=""
E D
.S ASUX(31)="GROUP RESTRICTED TO SELECTED SUB-STATIONS ONLY"
.S DIC("A")="Select Sub stations ",DIC="^ASUL(18,",DIC(0)="AEMQI"
.F D Q:Y<0
..D ^DIC Q:Y<0
..I $D(^ASUL(18,+Y,0)),$P(^ASUL(18,+Y,0),U)]"" S ASUU("SST",+Y)=+Y
.K DIC
KILSS ;
I '$D(ASUU("SST")) S ASUF("QU")=1 Q
K DIC,DIR,Y
Q ;Added quit here so would not go to USR twice. LMH 4/7/00
USR ;EP ;
;**********************************************************
;Now ask what users they wish to include on the report
;Choose ALL or SELECTED
;Routine returns a ASUU("USR",array) that holds the user
;pointers to table 17 (20)
;**********************************************************
K ASUU("USR"),DIR
S DIR("B")=1
S DIR(0)="S^1:Print 'ALL' users;2:Print 'SELECTED' users",DIR("A")="Users Print Criteria"
D ^DIR
I Y=1 D
.S ASUX(33)="GROUP INCLUDES ALL USERS"
.S ASUU("USR","*ALL*")=""
E D
.S ASUX(33)="GROUP INCLUDES SELECTED USERS ONLY"
.I '$D(ASUU("SST","*ALL*")) D
..S ASUU("SELU")=""
..F S ASUU("SELU")=$O(ASUU("SST",ASUU("SELU"))) Q:ASUU("SELU")="" D SU
.E D
..S ASUU("SELU")=0
..F S ASUU("SELU")=$O(^ASUMK(ASUU("SELU"))) Q:ASUU("SELU")'?1N.N D
...I ASUU("SELU")=ASUL(2,"STA","E#") D SU
Q
SU ;Select User for Sub-Station
;WAR 4/21/2000 originally this tag only had the 'Else' side of the
; 'If' statement. I added the 'If' statement to handle
; looking up USER codes by the Substation, then I included
; the check (another 'If') on the value returned in Y.
; An error or warning msg may be needed if a USER code is
; selected that is not associated with the substation.
I '$D(ASUU("SST","*ALL*")) D
.S DIC("A")="Select Sub station "_$E(ASUU("SELU"),3,5)_" Users: ",DIC="^ASUL(20,",DIC(0)="AEQMI"
.F D ^DIC Q:Y<0 Q:$D(DUOUT) I ASUU("SELU")=$E(Y,1,5) S ASUU("USR",ASUU("SELU"),+Y)=+Y
E D
.S DIC("A")="Select Sub station "_$E(ASUU("SELU"),3,5)_" Users: ",DIC="^ASUMK("_ASUU("SELU")_",1,",DIC(0)="AEQMI"
.F D ^DIC Q:Y<0 Q:$D(DUOUT) S ASUU("USR",ASUU("SELU"),+Y)=+Y
Q
ASURO26A ; IHS/ITSC/LMH -CUPBOARD STOCK BIN LABLES ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 26A, Cupboard Stock Bin Labels
+3 ;Report.
+4 ;WAR 5/21/99
QUIT
+5 KILL ^XTMP("ASUR","R26A")
+6 SET ^XTMP("ASUR","R26A",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
+7 DO SETAREA^ASULARST
+8 KILL ASUF("QU")
+9 DO DIR
+10 GOTO EXIT
DIR ;Menu
+1 ;
+2 FOR ASU1(10)=1:1:3
WRITE !,ASU1(10)," ",$PIECE($TEXT(@ASU1(10)),";",3)
IF ASU1(10)=3
Begin DoDot:1
+3 SET DIR(0)="L^1:3^S ASUV(""RP26"")=Y"
SET DIR("A")="ENTER SELECTION "
+4 WRITE !
+5 DO ^DIR
End DoDot:1
IF X["^"
SET ASUF("QU")=1
QUIT
+6 IF $DATA(ASUF("QU"))
QUIT
+7 KILL ASUU("SST")
+8 DO SST
IF $DATA(ASUF("QU"))
KILL ASUF("QU")
QUIT
+9 DO USR
IF $DATA(ASUF("QU"))
KILL ASUF("QU")
QUIT
+10 ;
Q ;Queue
+1 SET ZRTN="LIST^ASURO26A"
+2 SET ASUF("NOQUE")=1
+3 KILL IO("Q"),%ZIS,IOP
SET %ZIS="QM"
DO ^%ZIS
IF POP!('$DATA(IO("Q")))
QUIT
+4 KILL ZTDTH,ZTSAVE,ZTSK
SET ZTIO=ION
+5 FOR ASU1="ASUX(","ASUU(","ASUK(","ASUV(","DUZ("
SET ZTSAVE(ASU1)=""
+6 DO ^%ZTLOAD
WRITE !,"Report Queued.."
+7 IF POP!($DATA(IO("Q")))
KILL ASUF("QU")
DO COMPUTE
QUIT
+8 DO COMPUTE
GOTO LIST
COMPUTE ;
+1 SET ASUNW(4)=ASUV("RP26")
+2 FOR ASUNW(0)=1:1:$LENGTH(ASUNW(4),",")-1
SET ASUTG=$PIECE(ASUNW(4),",",ASUNW(0))
DO A0
+3 QUIT
LIST ;EP ;Taskman Entry Point
+1 DO HED
DO A1
EXIT ;
+1 IF $DATA(ASUNW)
IF '$DATA(^XTMP("ASUR","R26A"))
USE IO(0)
WRITE !!,"******** NO DATA FOUND *********"
+2 ;
+3 FOR X=10:1:21,29
KILL ASU1(X)
+4 KILL ASUF,ASUR,ASUNW,ASUTG,ASUV,ASUT,DIR,ZRTN,ASUMS,ASUMX,ASUMB
BYE ;
+1 KILL ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17),ASU1(18),ASU1(19),ASU1(20)
+2 KILL ASUC,ASUF,ASUFB,ASUMU,ASU1,ASUF("NOQUE"),ASUMX,ASUMS,ASUMB
+3 KILL ASUL,ASUR,ASUT,ASUTG,ASUX,DIR,ZTDESC,ZTIO,ZTRTN
+4 KILL ^XTMP("ASUR","R26A")
+5 KILL ASUT,ASUV,ASUC,ASUF("NOQUE"),ASUE
+6 DO PAZ^ASUURHDR
WRITE @IOF
DO ^%ZISC
+7 QUIT
HED ;Header vars
+1 SET ASUX(0)=$PIECE($TEXT(@ASUTG),";",3)
SET ASUX(1)="IND # "
SET ASUX(2)="U/I: "
SET ASUX(3)="USER LEVEL"
SET ASUX(4)="AR "
SET ASUX(5)="ST "
SET ASUX(6)="S-ST "
SET ASUX(7)="U-C "
+2 QUIT
1 ;;CUPBOARD STOCK BIN LABELS -ALPHA SEQ BY SUB STATION AND USER
2 ;;CUPBOARD STOCK BIN LABLES -ALPHA SEQ BY CATEGORY
3 ;;CUPBOARD STOCK BIN LABLES -INDEX SEQ
A0 ;
+1 SET X=$ORDER(ASUU("SST",""))
IF X']""
QUIT
+2 IF X="*ALL*"
Begin DoDot:1
+3 SET ASUX("STA")=ASUL(1,"AR","AP")_"000"
+4 FOR
SET ASUX("STA")=$ORDER(^ASUMK(ASUX("STA")))
IF $EXTRACT(ASUX("STA"),1,2)'=ASUL(1,"AR","AP")
QUIT
DO USER
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET ASUX("STA")=ASUL(2,"STA","E#")
+7 FOR
SET ASUX("STA")=$ORDER(ASUU("SST",ASUX("STA")))
IF ASUX("STA")']""
QUIT
DO USER
End DoDot:1
+8 KILL ASUMK,ASUMX,ASUMS,ASUC,ASUU,ASUC,ASUX
+9 QUIT
USER ;Process Users in Sub Station
+1 SET ASUMK("E#","STA")=ASUX("STA")
+2 SET X=$ORDER(ASUU("USR",""))
IF X']""
QUIT
+3 IF X="*ALL*"
Begin DoDot:1
+4 SET ASUX("USR")=ASUL(1,"AR","AP")_"0000"
+5 FOR
SET ASUX("USR")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUX("USR")))
IF ASUX("USR")'?1N.N
QUIT
DO BUILD
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET ASUX("USR")=""
+8 FOR
SET ASUX("USR")=$ORDER(ASUU("USR",ASUMK("E#","STA"),ASUX("USR")))
IF ASUX("USR")']""
QUIT
DO BUILD
End DoDot:1
+9 QUIT
BUILD ;Process Indexs in User
+1 SET ASUMK("E#","REQ")=ASUX("USR")
+2 SET ASUMK("E#","IDX")=0
+3 FOR ASUC("IDX")=1:1
SET ASUMK("E#","IDX")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX")))
IF ASUMK("E#","IDX")'?1N.N
QUIT
Begin DoDot:1
+4 IF ASUC("IDX")#20=0
WRITE "."
+5 DO READ^ASUMKBIO
+6 SET ASUMS("E#","STA")=$GET(ASUL(1,"AR","STA1"))
+7 IF ASUMS("E#","STA")']""
SET ASUMS("E#","STA")=ASUMK("E#","STA")
+8 DO DIS^ASUMDIRM(ASUMS("E#","STA"))
IF Y<0
Begin DoDot:2
+9 SET ASUMS("E#","STA")=$ORDER(^ASUMS("C",ASUMK("E#","IDX"),""))
End DoDot:2
+10 IF '$DATA(^ASUMS("C",ASUMK("E#","IDX"),ASUMS("E#","STA")))
Begin DoDot:2
+11 SET ASUMS("E#","STA")=$ORDER(^ASUMS("C",ASUMK("E#","IDX"),""))
End DoDot:2
+12 IF ASUMS("E#","STA")']""
Begin DoDot:2
+13 WRITE *7,!,"*** ERROR *** -Unable to find Station for Index # ",$EXTRACT(ASUMK("E#","IDX"),3,8)," for to Sub Station ",$EXTRACT(ASUMK("E#","STA"),3,5)
End DoDot:2
QUIT
+14 SET ASUMS(2)=^ASUMS(ASUMS("E#","STA"),1,ASUMK("E#","IDX"),2)
+15 SET ASUMX(0)=^ASUMX(ASUMK("E#","IDX"),0)
+16 SET ASUMS("EOQ","TP")=$PIECE(ASUMS(2),U,5)
+17 SET ASUMS("SLC")=$PIECE(ASUMS(2),U)
+18 SET ASUMX("ACC")=$PIECE(ASUMX(0),U,6)
+19 SET ASUMX("CAT")=$PIECE(ASUMX(0),U,8)
+20 SET ASUMX("DESC",1)=$EXTRACT($PIECE(ASUMX(0),U,2),1,30)
+21 SET ASUMX("DESC",2)=$EXTRACT($PIECE(ASUMX(0),U,2),31,60)
+22 SET ASUX("ACCG")=$SELECT(ASUMX("ACC")=1:1,ASUMX("ACC")=3:3,1:4)
+23 SET ASUX("SLC")=$SELECT(ASUMS("SLC")="H":"H",ASUMS("SLC")="R":"R",1:"Z")
+24 SET ASUX("CAT")=$SELECT(+ASUV("RP26")=2:ASUMX("CAT"),1:"*")
+25 IF ASUX("CAT")']""
SET ASUX("CAT")="*"
+26 SET ASUX("IDX")=$SELECT(+ASUV("RP26")=3:ASUMX("IDX"),1:ASUMX("DESC",1))
+27 SET X=$EXTRACT(ASUMX("IDX"),1,5)_"."_$EXTRACT(ASUMX("IDX"),6,6)_U_ASUMX("AR U/I")_U_ASUMX("DESC",1)
+28 SET X=X_U_ASUMX("DESC",2)_U_ASUMK("ULQTY")_U_ASUL(1,"AR","AP")_U_ASUMS("E#","STA")_U_ASUMK("SST")_U_ASUMK("USR")
+29 SET ^XTMP("ASUR","R26A",ASUX("STA"),ASUX("USR"),ASUX("ACCG"),ASUX("SLC"),ASUX("CAT"),ASUX("IDX"))=X
+30 KILL X
End DoDot:1
+31 QUIT
A1 ;
+1 IF '$DATA(^XTMP("ASUR","R26A"))
QUIT
+2 ;Print initial header
+3 USE IO
+4 KILL ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17),ASU1(18),ASU1(19),ASU1(20)
+5 SET ASU1(11)=""
+6 FOR
SET ASU1(11)=$ORDER(^XTMP("ASUR","R26A",ASU1(11)))
IF ASU1(11)=""
QUIT
Begin DoDot:1
+7 SET ASU1(12)=""
SET ASU2(2)=0
+8 FOR
SET ASU1(12)=$ORDER(^XTMP("ASUR","R26A",ASU1(11),ASU1(12)))
IF ASU1(12)=""
QUIT
Begin DoDot:2
+9 SET ASU1(13)=""
SET ASU2(3)=0
+10 FOR
SET ASU1(13)=$ORDER(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13)))
IF ASU1(13)=""
QUIT
Begin DoDot:3
+11 SET ASU1(14)=""
SET ASU2(4)=0
+12 FOR
SET ASU1(14)=$ORDER(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14)))
IF ASU1(14)=""
QUIT
Begin DoDot:4
+13 SET ASU1(15)=""
SET ASU2(5)=0
+14 FOR
SET ASU1(15)=$ORDER(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15)))
IF ASU1(15)=""
QUIT
DO SLC
SET ASU2(5)=1
+15 IF ASU2(6)
DO NEWPAGE
QUIT
+16 SET ASU2(5)=0
QUIT
End DoDot:4
SET ASU2(4)=1
+17 IF ASU2(5)
DO NEWPAGE
QUIT
+18 SET ASU2(4)=0
QUIT
End DoDot:3
SET ASU2(3)=1
+19 IF ASU2(4)
DO NEWPAGE
QUIT
+20 SET ASU2(3)=0
QUIT
End DoDot:2
SET ASU2(2)=1
+21 IF ASU2(3)
DO NEWPAGE
QUIT
+22 SET ASU2(2)=0
QUIT
End DoDot:1
+23 IF ASU2(2)
DO NEWPAGE
QUIT
+24 QUIT
SLC ;Order on ASU1(16)...it will be in form STORAGE LOCATION H,R,or *
+1 SET ASU1(16)=""
SET ASU2(6)=0
+2 FOR
SET ASU1(16)=$ORDER(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16)))
IF ASU1(16)=""
QUIT
Begin DoDot:1
+3 SET ASU1(17)=""
SET ASU2(7)=0
+4 FOR
SET ASU1(17)=$ORDER(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17)))
IF ASU1(17)=""
QUIT
Begin DoDot:2
+5 WRITE !,"LABELS FOR USER ",ASU1(14),!?11,"ACCOUNT ",ASU1(15)
+6 WRITE !?11,"LOCATION ",$SELECT(ASU1(16)="Z":"",1:ASU1(16)),!?11,"CATEGORY ",$SELECT(ASU1(17)="*":"",1:ASU1(17)),!!
+7 SET ASU1(18)=""
SET ASU2(8)=0
+8 FOR
DO LOOP
IF ASU1(18)']""
QUIT
End DoDot:2
SET ASU2(7)=1
+9 IF ASU2(8)
DO NEWPAGE
QUIT
+10 SET ASU2(7)=0
QUIT
End DoDot:1
SET ASU2(6)=1
+11 IF ASU2(7)
DO NEWPAGE
QUIT
+12 SET ASU2(6)=0
QUIT
LOOP ;
+1 SET ASU1(21)=0
+2 FOR ASU1(19)=1:1:3
Begin DoDot:1
+3 SET ASU2(9)=0
+4 FOR
SET ASU1(18)=$ORDER(^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17),ASU1(18)))
IF ASU1(18)=""
SET ASU2(9)=1
Begin DoDot:2
+5 IF ASU2(9)
QUIT
+6 SET ASU1(21)=ASU1(21)+1
SET ASU2(8)=1
+7 SET ASUF("BK",ASU1(21))=1
+8 SET ASUT(0)=^XTMP("ASUR","R26A",ASU1(11),ASU1(12),ASU1(13),ASU1(14),ASU1(15),ASU1(16),ASU1(17),ASU1(18))
+9 FOR ASU1(20)=1:1:9
SET ASUC(ASU1(21),ASU1(20))=$PIECE(ASUT(0),U,ASU1(20))
+10 IF ASU1(21)=3
SET ASU2(9)=1
End DoDot:2
IF ASU2(9)
QUIT
+11 IF ASU1(21)<3
FOR
SET ASU1(21)=ASU1(21)+1
DO BLANK
IF ASU1(21)=3
QUIT
+12 SET ASU1(19)=3
End DoDot:1
IF ASU2(8)
DO COLUMN
+13 QUIT
BLANK ;blank out one labels worth of print fields
+1 SET ASUF("BK",ASU1(21))=0
+2 FOR ASU1(20)=1:1:9
SET ASUC(ASU1(21),ASU1(20))=""
+3 QUIT
NEWPAGE ;Form feed code
+1 QUIT
+2 DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
+3 WRITE @IOF
+4 QUIT
COLUMN ;Display columns
+1 WRITE !,ASUX(1),ASUC(1,1),?15,ASUX(2),ASUC(1,2),?24,ASUX(3)
+2 IF ASUF("BK",2)
WRITE ?41,ASUX(1),ASUC(2,1),?55,ASUX(2),ASUC(2,2),?64,ASUX(3)
+3 IF ASUF("BK",3)
WRITE ?81,ASUX(1),ASUC(3,1),?95,ASUX(2),ASUC(3,2),?104,ASUX(3)
+4 WRITE !,ASUC(1,3)
+5 IF ASUF("BK",2)
WRITE ?41,ASUC(2,3)
+6 IF ASUF("BK",3)
WRITE ?81,ASUC(3,3)
+7 WRITE !,ASUC(1,4),?37,ASUC(1,5)
+8 IF ASUF("BK",2)
WRITE ?41,ASUC(2,4),?73,ASUC(2,5)
+9 IF ASUF("BK",3)
WRITE ?81,ASUC(3,4),?115,ASUC(3,5)
+10 WRITE !,ASUX(4),ASUC(1,6),?7,ASUX(5),ASUC(1,7),?13,ASUX(6),ASUC(1,8),?21,ASUX(7),ASUC(1,9)
+11 IF ASUF("BK",2)
WRITE ?41,ASUX(4),ASUC(2,6),?51,ASUX(5),ASUC(2,7),?57,ASUX(6),ASUC(2,8),?65,ASUX(7),ASUC(2,9)
+12 IF ASUF("BK",3)
WRITE ?81,ASUX(4),ASUC(3,6),?87,ASUX(5),ASUC(3,7),?93,ASUX(6),ASUC(3,8),?101,ASUX(7),ASUC(3,9)
+13 WRITE !!
+14 IF '$DATA(ASUC("LAB"))
SET ASUC("LAB")=0
SET ASUC("LAB")=ASUC("LAB")+1
IF ASUC("LAB")=9
SET ASUC("LAB")=0
DO NEWPAGE
+15 QUIT
SST ;EP ;
+1 ;********************************************************
+2 ;Reports are running by sub-station. A futher breakdown
+3 ;is now determined. Run ALL or SELECTED
+4 ;This routine will return a ASUU("SST",E#) that holds the entry numbers
+5 ;*********************************************************
+6 KILL ASUU("SST"),DIR
SET ASUX(32)="GROUP SUB-TOTALED BY: NO SUB-TOTALS"
+7 SET DIR(0)="S^1:Print 'ALL' sub-stations;2:Print 'SELECTED' sub-stations"
SET DIR("A")="Sub-Station Print Criteria"
+8 DO ^DIR
IF Y="^"
GOTO KILSS
+9 IF Y=1
Begin DoDot:1
+10 SET ASUX(31)="GROUP RESTRICTED TO ALL SUB-STATIONS"
+11 SET ASUU("SST","*ALL*")=""
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET ASUX(31)="GROUP RESTRICTED TO SELECTED SUB-STATIONS ONLY"
+14 SET DIC("A")="Select Sub stations "
SET DIC="^ASUL(18,"
SET DIC(0)="AEMQI"
+15 FOR
Begin DoDot:2
+16 DO ^DIC
IF Y<0
QUIT
+17 IF $DATA(^ASUL(18,+Y,0))
IF $PIECE(^ASUL(18,+Y,0),U)]""
SET ASUU("SST",+Y)=+Y
End DoDot:2
IF Y<0
QUIT
+18 KILL DIC
End DoDot:1
KILSS ;
+1 IF '$DATA(ASUU("SST"))
SET ASUF("QU")=1
QUIT
+2 KILL DIC,DIR,Y
+3 ;Added quit here so would not go to USR twice. LMH 4/7/00
QUIT
USR ;EP ;
+1 ;**********************************************************
+2 ;Now ask what users they wish to include on the report
+3 ;Choose ALL or SELECTED
+4 ;Routine returns a ASUU("USR",array) that holds the user
+5 ;pointers to table 17 (20)
+6 ;**********************************************************
+7 KILL ASUU("USR"),DIR
+8 SET DIR("B")=1
+9 SET DIR(0)="S^1:Print 'ALL' users;2:Print 'SELECTED' users"
SET DIR("A")="Users Print Criteria"
+10 DO ^DIR
+11 IF Y=1
Begin DoDot:1
+12 SET ASUX(33)="GROUP INCLUDES ALL USERS"
+13 SET ASUU("USR","*ALL*")=""
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 SET ASUX(33)="GROUP INCLUDES SELECTED USERS ONLY"
+16 IF '$DATA(ASUU("SST","*ALL*"))
Begin DoDot:2
+17 SET ASUU("SELU")=""
+18 FOR
SET ASUU("SELU")=$ORDER(ASUU("SST",ASUU("SELU")))
IF ASUU("SELU")=""
QUIT
DO SU
End DoDot:2
+19 IF '$TEST
Begin DoDot:2
+20 SET ASUU("SELU")=0
+21 FOR
SET ASUU("SELU")=$ORDER(^ASUMK(ASUU("SELU")))
IF ASUU("SELU")'?1N.N
QUIT
Begin DoDot:3
+22 IF ASUU("SELU")=ASUL(2,"STA","E#")
DO SU
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
SU ;Select User for Sub-Station
+1 ;WAR 4/21/2000 originally this tag only had the 'Else' side of the
+2 ; 'If' statement. I added the 'If' statement to handle
+3 ; looking up USER codes by the Substation, then I included
+4 ; the check (another 'If') on the value returned in Y.
+5 ; An error or warning msg may be needed if a USER code is
+6 ; selected that is not associated with the substation.
+7 IF '$DATA(ASUU("SST","*ALL*"))
Begin DoDot:1
+8 SET DIC("A")="Select Sub station "_$EXTRACT(ASUU("SELU"),3,5)_" Users: "
SET DIC="^ASUL(20,"
SET DIC(0)="AEQMI"
+9 FOR
DO ^DIC
IF Y<0
QUIT
IF $DATA(DUOUT)
QUIT
IF ASUU("SELU")=$EXTRACT(Y,1,5)
SET ASUU("USR",ASUU("SELU"),+Y)=+Y
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET DIC("A")="Select Sub station "_$EXTRACT(ASUU("SELU"),3,5)_" Users: "
SET DIC="^ASUMK("_ASUU("SELU")_",1,"
SET DIC(0)="AEQMI"
+12 FOR
DO ^DIC
IF Y<0
QUIT
IF $DATA(DUOUT)
QUIT
SET ASUU("USR",ASUU("SELU"),+Y)=+Y
End DoDot:1
+13 QUIT
