ASURO800 ; IHS/ITSC/LMH -RPT 80 ISS-ANAL SELECT ACCOUNTS ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine sorts report 80 extracts into proper sequence so that the
;report can be formatted and printed.
D:'$D(IO) HOME^%ZIS
I $D(^XTMP("ASUR","R80")) D
.S DIR("A")="Use Last Report 80 Selections",DIR(0)="Y",DIR("?")="^D LASL^ASURO80" D ^DIR K DIR
E S Y=0
I $D(DTOUT)!($D(DUOUT)) Q
I Y Q
EN1 ;EP;SELECT NEW PARAMETERS
S ASUT="R80"
K ^XTMP("ASUR","R80")
S ^XTMP("ASUR","R80",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
S ASUF("ALL","ACC")=0,DIR("A")="Report on all Accounts",DIR(0)="Y" D ^DIR Q:$D(DUOUT) Q:$D(DTOUT)
I Y D
.S ASUF("ALL","ACC")=1 K DIR
.F X=0:0 S X=$O(^ASUL(9,X)) Q:X'?1N.N S ^XTMP("ASUR","R80",0,X)=X_U_$P(^ASUL(9,X,0),U)
E D
.K DIR
.F D Q:$D(DTOUT)!($D(DUOUT))!(Y<0)
..S DIR("A")="Report for what Account",DIR(0)="PO^9002039.09:MXEZ",DIR("?")="Enter valid Account Code " D ^DIR
..I $D(DTOUT)!($D(DUOUT)!(Y<0)) Q
..S ^XTMP("ASUR","R80",0,+Y)=Y
I $D(DTOUT)!($D(DUOUT)) Q
S ASUT(ASUT,"ACC")=""
F S ASUT(ASUT,"ACC")=$O(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"))) Q:ASUT(ASUT,"ACC")']"" D ASURO801
S ASUF("OK")=1
S DIR(0)="Y",DIR("A")="Do you want to review your selections" D ^DIR
I Y D
.D SEL
.W !!,"In answering the following, a response of 'Y' will process your Selections"
.W !,"An answer of 'N' will erase your selections and allow you to enter new ones",!
.S DIR("A")="Are selections OK"
.D ^DIR
.K DIR
.I Y D
..S ASUF("OK")=1
.E D
..S ASUF("OK")=0
I $D(DUOUT)!($D(DTOUT)) K ^XTMP("ASUR","R80") Q
I 'ASUF("OK") G EN1
W !!,"Gathering Data for your Selections",!
S ASUMX("E#","IDX")=0
F S ASUMX("E#","IDX")=$O(^ASUMX(ASUMX("E#","IDX"))) Q:ASUMX("E#","IDX")'?1N.N D
.D READ^ASUMXDIO Q:ASUMX("CAT")']""
.I $D(^XTMP("ASUR","R80",0,ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"))) D
..W "."
..S ^XTMP("ASUR","R80",1,ASUMX("IDX"))=ASUMX("E#","IDX")
D:'$D(ASUK("DT","FM")) ^ASUUDATE
S ^XTMP("ASUR","R80",2)=ASUK("DT","FM")
D ASURO803
K X,ASUF("ALL")
Q
ASURO801 ;
I ASUF("ALL","ACC") D
.S Y=1
E D
.S DIR("A")="Report on all Object Sub-Objects for Account "_ASUT(ASUT,"ACC"),DIR(0)="Y" D ^DIR
I $D(DTOUT)!($D(DUOUT)) Q
I Y D
.S ASUF("ALL","OBJ")=1 K X,DIR
.F Y=0:0 S Y=$O(^ASUL(3,Y)) Q:Y'?1N.N D
..S (ASUT(ASUT,"SOBJ"),X)=^ASUL(3,Y,1) D SCROBJ Q:'$T
..S ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"))=Y_U_^ASUL(3,Y,0)
E D
.F D Q:$D(DTOUT)!($D(DUOUT))!(ASUT(ASUT,"SOBJ")="")
..S ASUF("ALL","OBJ")=0,DIR(0)="PO^9002039.03:MXZEA",DIR("A")="Select Object Sub-Object: ",ASUT("TRCD")=""
..D READOBJ I $D(DUOUT)!($D(DTOUT))!(ASUT(ASUT,"SOBJ")="") Q
..D SSO^ASULDIRF(ASUL(3,"SOBJ","E#"))
..S ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"))=ASUL(3,"SOBJ","E#")_U_ASUL(3,"SOBJ","NM")
.K DIR,X,Y
S ASUT(ASUT,"SOBJ")=""
F S ASUT(ASUT,"SOBJ")=$O(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"))) Q:ASUT(ASUT,"SOBJ")']"" D ASURO802
Q
ASURO802 ;
S ASUL(3,"SOBJ","E#")=$P(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ")),U)
I ASUT(ASUT,"ACC")=$G(ASUV("ACC")) D
.S ASUV("ACC")=ASUT(ASUT,"ACC") W !,"PROCESSING ACCOUNT: ",ASUT(ASUT,"ACC")
I ASUF("ALL","OBJ") D
.S Y=1
E D
.S DIR("A")="Report on all Categorys for Ofject Sub-Object "_ASUT(ASUT,"SOBJ"),DIR(0)="Y" D ^DIR
I $D(DTOUT)!($D(DUOUT)) Q
I Y D
.K X,Y,DIR
.S ASUF("ALL","CAT")=1,Y=ASUL(3,"SOBJ","E#")_"00"
.F S Y=$O(^ASUL(7,Y)) Q:ASUL(3,"SOBJ","E#")'=$E(Y,1,3) D
..S (ASUL(7,"CAT","CD"),X)=$P(^ASUL(7,Y,1),U)
..S ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"),ASUL(7,"CAT","CD"))=Y_U_^ASUL(7,Y,0)
E D
.S ASUF("ALL","CAT")=0
.F D Q:$G(ASUT(ASUT,"CAT"))']""!($D(DTOUT))!($D(DUOUT))
..S DIR("A")="Select Category: ",ASUS("OPTN")="PO" D READCAT Q:ASUT(ASUT,"CAT")']""
..D CAT^ASULDIRF(ASUL(7,"CAT","E#"))
..I $D(DUOUT)!($D(DTOUT)) Q
..S ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"),ASUL(7,"CAT","CD"))=ASUL(7,"CAT","E#")_U_ASUL(7,"CAT","NM")
K DIR,X,Y
Q
ASURO803 ;
S ASUL(2,"STA","E#")=$G(ASUL(1,"AR","STA1"))
I ASUL(2,"STA","E#")']"" W !,"SORRY, YOU AREA NOT AUTHORIZED TO RUN THIS REPORT" K DIR S DIR(0)="E" D ^DIR S DUOUT=1 Q
D STA^ASULARST(ASUL(2,"STA","E#"))
S ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"))=ASUL(1,"AR","NM")
S ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUL(2,"STA","E#"))=ASUL(2,"STA","NM")_U_ASUL(2,"STA","CD")
S ASUX("IDX")=""
F S ASUX("IDX")=$O(^XTMP("ASUR","R80",1,ASUX("IDX"))) Q:ASUX("IDX")']"" D
.S ASUMK("E#","STA")="",ASUMK("E#","IDX")=^XTMP("ASUR","R80",1,ASUX("IDX"))
.F S ASUMK("E#","STA")=$O(^ASUMK("C",ASUMK("E#","IDX"),ASUMK("E#","STA"))) Q:ASUMK("E#","STA")']"" D
..W "."
..S ASUMK("E#","REQ")=""
..F S ASUMK("E#","REQ")=$O(^ASUMK("C",ASUMK("E#","IDX"),ASUMK("E#","STA"),ASUMK("E#","REQ"))) Q:ASUMK("E#","REQ")']"" D IBMST
Q
IBMST ;
D READ^ASUMKBIO
S ASUL(18,"E#","SST")=$E(ASUMK("E#","REQ"),1,5) D SST^ASULDIRR(ASUL(18,"E#","SST")),REQ^ASULDIRR(ASUMK("E#","REQ"))
S ASUMX("E#","IDX")=^XTMP("ASUR","R80",1,ASUMK("IDX"))
D READ^ASUMXDIO
S $P(^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),ASUL(18,"E#","SST")),U)=ASUL(18,"SST","NM")
S ASUX(2)=^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),ASUL(18,"E#","SST"))
S $P(ASUX(2),U,2)=$P(ASUX(2),U,2)+ASUMK("CFY","VAL")
S $P(ASUX(2),U,3)=$P(ASUX(2),U,3)+ASUMK("PFY","VAL")
S $P(ASUX(2),U,4)=$P(ASUX(2),U,4)+ASUMK("PPY","VAL")
S ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),+ASUL(18,"E#","SST"))=ASUX(2)
S $P(^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1)),U,4)=ASUMX("E#","IDX")
S ASUX=^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1))
S $P(ASUX,U)=$P(ASUX,U)+ASUMK("CFY","VAL")
S $P(ASUX,U,2)=$P(ASUX,U,2)+ASUMK("PFY","VAL")
S $P(ASUX,U,3)=$P(ASUX,U,3)+ASUMK("PPY","VAL")
S $P(ASUX,U,5)=ASUMX("IDX")
S $P(ASUX,U,6)=ASUMX("DESC",2)
S ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1))=ASUX
Q
ASURO805 ;
LASL ;LIST LAST REPORT 80'S SELECTIONS
S ASUC=0
W !,"Last Selection(s) were:" S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
G CONTU
SEL ;LIST REPORT 80 SELECTIONS
S ASUC=0
W !,"Your Selection(s) are:" S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
CONTU ;
F S ASUL=$O(^XTMP("ASUR","R80",0,$G(ASUL))) Q:ASUL']"" D Q:$D(DTOUT)!($D(DUOUT))
.W !?2,"Account: ",ASUL," ",$P(^XTMP("ASUR","R80",0,ASUL),U,2) S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
.F S ASUA(1)=$O(^XTMP("ASUR","R80",0,ASUL,$G(ASUA(1)))) Q:ASUA(1)']"" D Q:$D(DTOUT)!($D(DUOUT))
..W !?4,"Object Sub Object: ",ASUA(1)," ",$P(^XTMP("ASUR","R80",0,ASUL,ASUA(1)),U,2) S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
..F S ASUA(2)=$O(^XTMP("ASUR","R80",0,ASUL,ASUA(1),$G(ASUA(2)))) Q:ASUA(2)']"" D Q:$D(DTOUT)!($D(DUOUT))
...W !?6,"Category: ",ASUA(2)," ",$P(^XTMP("ASUR","R80",0,ASUL,ASUA(1),ASUA(2)),U,2) S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
K ASUC,ASUF,ASUMX,ASUMS,ASUT,ASUV,ASUX
Q
PAUSE ;EP;PAUSE AT END OF SCREEN
Q:ASUC<IOSL
N DIR
S DIR(0)="E" D ^DIR
S ASUC=0
Q
READOBJ ;READ OBJECT SUB OBJECT CODE
I ASUT(ASUT,"ACC")="" S ASUT(ASUT,"SOBJ")="" W !,DIR("A"),":" Q
S DIR("S")="D SCROBJ^ASURO800"
S DIR("?")="Object-Sub-Object not valid for Account "_ASUT(ASUT,"ACC")
D ASU0EDIR
I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) Q
I Y<0 D
.S (ASUL(3,"SOBJ","E#"),ASUT(ASUT,"SOBJ"))=""
E D
.S ASUL(3,"SOBJ","E#")=+Y
.S ASUV("SOBJ","NM")=$P(Y,U,2)
.S ASUT(ASUT,"SOBJ")=$P(^ASUL(3,ASUL(3,"SOBJ","E#"),1),U)
.I ASUT("TRCD")="4C" S ASUS("CHG")=1
K DIR,X,Y
Q
SCROBJ ;EP ;SCREEN
I $E(Y)=ASUT(ASUT,"ACC")
Q
READCAT ;EP; READ CATEGORY
N DIR,X,Y
S DIR("S")="D SCRCAT^ASURO800"
S DIC("W")="W ?70,"" "",$P(^(1),U)"
S DIR("?")="Category not valid for Account "_ASUT(ASUT,"ACC")_" and Object-Sub-Object "_ASUT(ASUT,"SOBJ")
I $G(ASUS("OPTN"))']"" D
.S ASUS("OPTN")="PO"
.I ASUT(ASUT,"ACC")]"",ASUT(ASUT,"SOBJ")]"" S ASUS("OPTN")="P"
S DIR(0)=ASUS("OPTN")_"^9002039.07:MXZA" K ASUS("OPTN")
D ASU0EDIR
I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) Q
I Y>0 D
.S ASUL(7,"CAT","E#")=+Y,ASUT(ASUT,"CAT NM")=$P(Y,U,2)
.S ASUT(ASUT,"CAT")=$P(^ASUL(7,ASUL(7,"CAT","E#"),1),U)
.W " ",ASUT(ASUT,"CAT")," ",ASUT(ASUT,"CAT NM")
E D
.S ASUT(ASUT,"CAT")=""
I ASUT(ASUT,"CAT")]"" S:ASUT("TRCD")="4C" ASUS("CHG")=1
Q
SCRCAT ;SCREENING LOGIC
I $E(Y)=ASUL(9,"ACC","E#"),$E(Y,1,3)=ASUL(3,"SOBJ","E#")
Q
ASU0EDIR ;
N X
S:$D(DIR("S")) DIC("S")=DIR("S")
S DIC("A")=DIR("A")
I $D(DIR("B")) W DIR("B"),"// " S DIC("B")=DIR("B")
S DIC=$P($P(DIR(0),U,2),":")
S:DIC'?1N.E DIC=U_DIC
S DIC(0)=$P($P(DIR(0),U,2),":",2)
I $P(DIR(0),U)'["O" D
.F D ^DIC Q:$D(DTOUT)!($D(DUOUT)) Q:+Y>0 W " Field is Required",!
E D
.D ^DIC
K DIC
Q
ASURO800 ; IHS/ITSC/LMH -RPT 80 ISS-ANAL SELECT ACCOUNTS ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine sorts report 80 extracts into proper sequence so that the
+3 ;report can be formatted and printed.
+4 IF '$DATA(IO)
DO HOME^%ZIS
+5 IF $DATA(^XTMP("ASUR","R80"))
Begin DoDot:1
+6 SET DIR("A")="Use Last Report 80 Selections"
SET DIR(0)="Y"
SET DIR("?")="^D LASL^ASURO80"
DO ^DIR
KILL DIR
End DoDot:1
+7 IF '$TEST
SET Y=0
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+9 IF Y
QUIT
EN1 ;EP;SELECT NEW PARAMETERS
+1 SET ASUT="R80"
+2 KILL ^XTMP("ASUR","R80")
+3 SET ^XTMP("ASUR","R80",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
+4 SET ASUF("ALL","ACC")=0
SET DIR("A")="Report on all Accounts"
SET DIR(0)="Y"
DO ^DIR
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+5 IF Y
Begin DoDot:1
+6 SET ASUF("ALL","ACC")=1
KILL DIR
+7 FOR X=0:0
SET X=$ORDER(^ASUL(9,X))
IF X'?1N.N
QUIT
SET ^XTMP("ASUR","R80",0,X)=X_U_$PIECE(^ASUL(9,X,0),U)
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 KILL DIR
+10 FOR
Begin DoDot:2
+11 SET DIR("A")="Report for what Account"
SET DIR(0)="PO^9002039.09:MXEZ"
SET DIR("?")="Enter valid Account Code "
DO ^DIR
+12 IF $DATA(DTOUT)!($DATA(DUOUT)!(Y<0))
QUIT
+13 SET ^XTMP("ASUR","R80",0,+Y)=Y
End DoDot:2
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
QUIT
End DoDot:1
+14 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+15 SET ASUT(ASUT,"ACC")=""
+16 FOR
SET ASUT(ASUT,"ACC")=$ORDER(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC")))
IF ASUT(ASUT,"ACC")']""
QUIT
DO ASURO801
+17 SET ASUF("OK")=1
+18 SET DIR(0)="Y"
SET DIR("A")="Do you want to review your selections"
DO ^DIR
+19 IF Y
Begin DoDot:1
+20 DO SEL
+21 WRITE !!,"In answering the following, a response of 'Y' will process your Selections"
+22 WRITE !,"An answer of 'N' will erase your selections and allow you to enter new ones",!
+23 SET DIR("A")="Are selections OK"
+24 DO ^DIR
+25 KILL DIR
+26 IF Y
Begin DoDot:2
+27 SET ASUF("OK")=1
End DoDot:2
+28 IF '$TEST
Begin DoDot:2
+29 SET ASUF("OK")=0
End DoDot:2
End DoDot:1
+30 IF $DATA(DUOUT)!($DATA(DTOUT))
KILL ^XTMP("ASUR","R80")
QUIT
+31 IF 'ASUF("OK")
GOTO EN1
+32 WRITE !!,"Gathering Data for your Selections",!
+33 SET ASUMX("E#","IDX")=0
+34 FOR
SET ASUMX("E#","IDX")=$ORDER(^ASUMX(ASUMX("E#","IDX")))
IF ASUMX("E#","IDX")'?1N.N
QUIT
Begin DoDot:1
+35 DO READ^ASUMXDIO
IF ASUMX("CAT")']""
QUIT
+36 IF $DATA(^XTMP("ASUR","R80",0,ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT")))
Begin DoDot:2
+37 WRITE "."
+38 SET ^XTMP("ASUR","R80",1,ASUMX("IDX"))=ASUMX("E#","IDX")
End DoDot:2
End DoDot:1
+39 IF '$DATA(ASUK("DT","FM"))
DO ^ASUUDATE
+40 SET ^XTMP("ASUR","R80",2)=ASUK("DT","FM")
+41 DO ASURO803
+42 KILL X,ASUF("ALL")
+43 QUIT
ASURO801 ;
+1 IF ASUF("ALL","ACC")
Begin DoDot:1
+2 SET Y=1
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 SET DIR("A")="Report on all Object Sub-Objects for Account "_ASUT(ASUT,"ACC")
SET DIR(0)="Y"
DO ^DIR
End DoDot:1
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+6 IF Y
Begin DoDot:1
+7 SET ASUF("ALL","OBJ")=1
KILL X,DIR
+8 FOR Y=0:0
SET Y=$ORDER(^ASUL(3,Y))
IF Y'?1N.N
QUIT
Begin DoDot:2
+9 SET (ASUT(ASUT,"SOBJ"),X)=^ASUL(3,Y,1)
DO SCROBJ
IF '$TEST
QUIT
+10 SET ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"))=Y_U_^ASUL(3,Y,0)
End DoDot:2
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 FOR
Begin DoDot:2
+13 SET ASUF("ALL","OBJ")=0
SET DIR(0)="PO^9002039.03:MXZEA"
SET DIR("A")="Select Object Sub-Object: "
SET ASUT("TRCD")=""
+14 DO READOBJ
IF $DATA(DUOUT)!($DATA(DTOUT))!(ASUT(ASUT,"SOBJ")="")
QUIT
+15 DO SSO^ASULDIRF(ASUL(3,"SOBJ","E#"))
+16 SET ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"))=ASUL(3,"SOBJ","E#")_U_ASUL(3,"SOBJ","NM")
End DoDot:2
IF $DATA(DTOUT)!($DATA(DUOUT))!(ASUT(ASUT,"SOBJ")="")
QUIT
+17 KILL DIR,X,Y
End DoDot:1
+18 SET ASUT(ASUT,"SOBJ")=""
+19 FOR
SET ASUT(ASUT,"SOBJ")=$ORDER(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ")))
IF ASUT(ASUT,"SOBJ")']""
QUIT
DO ASURO802
+20 QUIT
ASURO802 ;
+1 SET ASUL(3,"SOBJ","E#")=$PIECE(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ")),U)
+2 IF ASUT(ASUT,"ACC")=$GET(ASUV("ACC"))
Begin DoDot:1
+3 SET ASUV("ACC")=ASUT(ASUT,"ACC")
WRITE !,"PROCESSING ACCOUNT: ",ASUT(ASUT,"ACC")
End DoDot:1
+4 IF ASUF("ALL","OBJ")
Begin DoDot:1
+5 SET Y=1
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET DIR("A")="Report on all Categorys for Ofject Sub-Object "_ASUT(ASUT,"SOBJ")
SET DIR(0)="Y"
DO ^DIR
End DoDot:1
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+9 IF Y
Begin DoDot:1
+10 KILL X,Y,DIR
+11 SET ASUF("ALL","CAT")=1
SET Y=ASUL(3,"SOBJ","E#")_"00"
+12 FOR
SET Y=$ORDER(^ASUL(7,Y))
IF ASUL(3,"SOBJ","E#")'=$EXTRACT(Y,1,3)
QUIT
Begin DoDot:2
+13 SET (ASUL(7,"CAT","CD"),X)=$PIECE(^ASUL(7,Y,1),U)
+14 SET ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"),ASUL(7,"CAT","CD"))=Y_U_^ASUL(7,Y,0)
End DoDot:2
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 SET ASUF("ALL","CAT")=0
+17 FOR
Begin DoDot:2
+18 SET DIR("A")="Select Category: "
SET ASUS("OPTN")="PO"
DO READCAT
IF ASUT(ASUT,"CAT")']""
QUIT
+19 DO CAT^ASULDIRF(ASUL(7,"CAT","E#"))
+20 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+21 SET ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"),ASUL(7,"CAT","CD"))=ASUL(7,"CAT","E#")_U_ASUL(7,"CAT","NM")
End DoDot:2
IF $GET(ASUT(ASUT,"CAT"))']""!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
End DoDot:1
+22 KILL DIR,X,Y
+23 QUIT
ASURO803 ;
+1 SET ASUL(2,"STA","E#")=$GET(ASUL(1,"AR","STA1"))
+2 IF ASUL(2,"STA","E#")']""
WRITE !,"SORRY, YOU AREA NOT AUTHORIZED TO RUN THIS REPORT"
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DUOUT=1
QUIT
+3 DO STA^ASULARST(ASUL(2,"STA","E#"))
+4 SET ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"))=ASUL(1,"AR","NM")
+5 SET ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUL(2,"STA","E#"))=ASUL(2,"STA","NM")_U_ASUL(2,"STA","CD")
+6 SET ASUX("IDX")=""
+7 FOR
SET ASUX("IDX")=$ORDER(^XTMP("ASUR","R80",1,ASUX("IDX")))
IF ASUX("IDX")']""
QUIT
Begin DoDot:1
+8 SET ASUMK("E#","STA")=""
SET ASUMK("E#","IDX")=^XTMP("ASUR","R80",1,ASUX("IDX"))
+9 FOR
SET ASUMK("E#","STA")=$ORDER(^ASUMK("C",ASUMK("E#","IDX"),ASUMK("E#","STA")))
IF ASUMK("E#","STA")']""
QUIT
Begin DoDot:2
+10 WRITE "."
+11 SET ASUMK("E#","REQ")=""
+12 FOR
SET ASUMK("E#","REQ")=$ORDER(^ASUMK("C",ASUMK("E#","IDX"),ASUMK("E#","STA"),ASUMK("E#","REQ")))
IF ASUMK("E#","REQ")']""
QUIT
DO IBMST
End DoDot:2
End DoDot:1
+13 QUIT
IBMST ;
+1 DO READ^ASUMKBIO
+2 SET ASUL(18,"E#","SST")=$EXTRACT(ASUMK("E#","REQ"),1,5)
DO SST^ASULDIRR(ASUL(18,"E#","SST"))
DO REQ^ASULDIRR(ASUMK("E#","REQ"))
+3 SET ASUMX("E#","IDX")=^XTMP("ASUR","R80",1,ASUMK("IDX"))
+4 DO READ^ASUMXDIO
+5 SET $PIECE(^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),ASUL(18,"E#","SST")),U)=ASUL(18,"SST","NM")
+6 SET ASUX(2)=^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),ASUL(18,"E#","SST"))
+7 SET $PIECE(ASUX(2),U,2)=$PIECE(ASUX(2),U,2)+ASUMK("CFY","VAL")
+8 SET $PIECE(ASUX(2),U,3)=$PIECE(ASUX(2),U,3)+ASUMK("PFY","VAL")
+9 SET $PIECE(ASUX(2),U,4)=$PIECE(ASUX(2),U,4)+ASUMK("PPY","VAL")
+10 SET ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),+ASUL(18,"E#","SST"))=ASUX(2)
+11 SET $PIECE(^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1)),U,4)=ASUMX("E#","IDX")
+12 SET ASUX=^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1))
+13 SET $PIECE(ASUX,U)=$PIECE(ASUX,U)+ASUMK("CFY","VAL")
+14 SET $PIECE(ASUX,U,2)=$PIECE(ASUX,U,2)+ASUMK("PFY","VAL")
+15 SET $PIECE(ASUX,U,3)=$PIECE(ASUX,U,3)+ASUMK("PPY","VAL")
+16 SET $PIECE(ASUX,U,5)=ASUMX("IDX")
+17 SET $PIECE(ASUX,U,6)=ASUMX("DESC",2)
+18 SET ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1))=ASUX
+19 QUIT
ASURO805 ;
LASL ;LIST LAST REPORT 80'S SELECTIONS
+1 SET ASUC=0
+2 WRITE !,"Last Selection(s) were:"
SET ASUC=ASUC+1
DO PAUSE
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+3 GOTO CONTU
SEL ;LIST REPORT 80 SELECTIONS
+1 SET ASUC=0
+2 WRITE !,"Your Selection(s) are:"
SET ASUC=ASUC+1
DO PAUSE
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
CONTU ;
+1 FOR
SET ASUL=$ORDER(^XTMP("ASUR","R80",0,$GET(ASUL)))
IF ASUL']""
QUIT
Begin DoDot:1
+2 WRITE !?2,"Account: ",ASUL," ",$PIECE(^XTMP("ASUR","R80",0,ASUL),U,2)
SET ASUC=ASUC+1
DO PAUSE
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+3 FOR
SET ASUA(1)=$ORDER(^XTMP("ASUR","R80",0,ASUL,$GET(ASUA(1))))
IF ASUA(1)']""
QUIT
Begin DoDot:2
+4 WRITE !?4,"Object Sub Object: ",ASUA(1)," ",$PIECE(^XTMP("ASUR","R80",0,ASUL,ASUA(1)),U,2)
SET ASUC=ASUC+1
DO PAUSE
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+5 FOR
SET ASUA(2)=$ORDER(^XTMP("ASUR","R80",0,ASUL,ASUA(1),$GET(ASUA(2))))
IF ASUA(2)']""
QUIT
Begin DoDot:3
+6 WRITE !?6,"Category: ",ASUA(2)," ",$PIECE(^XTMP("ASUR","R80",0,ASUL,ASUA(1),ASUA(2)),U,2)
SET ASUC=ASUC+1
DO PAUSE
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
End DoDot:3
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
End DoDot:2
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
End DoDot:1
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+7 KILL ASUC,ASUF,ASUMX,ASUMS,ASUT,ASUV,ASUX
+8 QUIT
PAUSE ;EP;PAUSE AT END OF SCREEN
+1 IF ASUC<IOSL
QUIT
+2 NEW DIR
+3 SET DIR(0)="E"
DO ^DIR
+4 SET ASUC=0
+5 QUIT
READOBJ ;READ OBJECT SUB OBJECT CODE
+1 IF ASUT(ASUT,"ACC")=""
SET ASUT(ASUT,"SOBJ")=""
WRITE !,DIR("A"),":"
QUIT
+2 SET DIR("S")="D SCROBJ^ASURO800"
+3 SET DIR("?")="Object-Sub-Object not valid for Account "_ASUT(ASUT,"ACC")
+4 DO ASU0EDIR
+5 IF $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DTOUT))
QUIT
+6 IF Y<0
Begin DoDot:1
+7 SET (ASUL(3,"SOBJ","E#"),ASUT(ASUT,"SOBJ"))=""
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET ASUL(3,"SOBJ","E#")=+Y
+10 SET ASUV("SOBJ","NM")=$PIECE(Y,U,2)
+11 SET ASUT(ASUT,"SOBJ")=$PIECE(^ASUL(3,ASUL(3,"SOBJ","E#"),1),U)
+12 IF ASUT("TRCD")="4C"
SET ASUS("CHG")=1
End DoDot:1
+13 KILL DIR,X,Y
+14 QUIT
SCROBJ ;EP ;SCREEN
+1 IF $EXTRACT(Y)=ASUT(ASUT,"ACC")
+2 QUIT
READCAT ;EP; READ CATEGORY
+1 NEW DIR,X,Y
+2 SET DIR("S")="D SCRCAT^ASURO800"
+3 SET DIC("W")="W ?70,"" "",$P(^(1),U)"
+4 SET DIR("?")="Category not valid for Account "_ASUT(ASUT,"ACC")_" and Object-Sub-Object "_ASUT(ASUT,"SOBJ")
+5 IF $GET(ASUS("OPTN"))']""
Begin DoDot:1
+6 SET ASUS("OPTN")="PO"
+7 IF ASUT(ASUT,"ACC")]""
IF ASUT(ASUT,"SOBJ")]""
SET ASUS("OPTN")="P"
End DoDot:1
+8 SET DIR(0)=ASUS("OPTN")_"^9002039.07:MXZA"
KILL ASUS("OPTN")
+9 DO ASU0EDIR
+10 IF $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DTOUT))
QUIT
+11 IF Y>0
Begin DoDot:1
+12 SET ASUL(7,"CAT","E#")=+Y
SET ASUT(ASUT,"CAT NM")=$PIECE(Y,U,2)
+13 SET ASUT(ASUT,"CAT")=$PIECE(^ASUL(7,ASUL(7,"CAT","E#"),1),U)
+14 WRITE " ",ASUT(ASUT,"CAT")," ",ASUT(ASUT,"CAT NM")
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 SET ASUT(ASUT,"CAT")=""
End DoDot:1
+17 IF ASUT(ASUT,"CAT")]""
IF ASUT("TRCD")="4C"
SET ASUS("CHG")=1
+18 QUIT
SCRCAT ;SCREENING LOGIC
+1 IF $EXTRACT(Y)=ASUL(9,"ACC","E#")
IF $EXTRACT(Y,1,3)=ASUL(3,"SOBJ","E#")
+2 QUIT
ASU0EDIR ;
+1 NEW X
+2 IF $DATA(DIR("S"))
SET DIC("S")=DIR("S")
+3 SET DIC("A")=DIR("A")
+4 IF $DATA(DIR("B"))
WRITE DIR("B"),"// "
SET DIC("B")=DIR("B")
+5 SET DIC=$PIECE($PIECE(DIR(0),U,2),":")
+6 IF DIC'?1N.E
SET DIC=U_DIC
+7 SET DIC(0)=$PIECE($PIECE(DIR(0),U,2),":",2)
+8 IF $PIECE(DIR(0),U)'["O"
Begin DoDot:1
+9 FOR
DO ^DIC
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
IF +Y>0
QUIT
WRITE " Field is Required",!
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 DO ^DIC
End DoDot:1
+12 KILL DIC
+13 QUIT
