ASURO260 ; IHS/ITSC/LMH -S.A.M.S. REPORT 26 SORT ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine sorts report 26 extracts into proper sequence so that the
;report can be formatted and printed.
;WAR 4/20/2000 - Made several changes. See original code in DEV or ask
; Lucy Harmon or myself for hard copy.
S ASUNW(4)=ASUV("RP26")
S X=$O(ASUU("SST","")) Q:X']""
S (ASUMK("E#","STA"),ASUX("STA"))=ASUL(2,"STA","E#") ;WAR 4/20/2000
S (ASUXSST,ASUX("SST"))=0
I X="*ALL*" D ;WAR 4/19/2000 Note:this is SUBstations not Stations.
.F S ASUXSST=$O(^ASUMK(ASUX("STA"),1,ASUXSST)) Q:ASUXSST="" D
..S ASUX("SST")=$E(ASUXSST,1,5)
..D USER
E D
.F S ASUX("SST")=$O(ASUU("SST",ASUX("SST"))) Q:ASUX("SST")="" D
..D USER
K ASUMK,ASUMX,ASUMS,ASUC,ASUU,ASUC,ASUX
Q
USER ;
S ASUX("USR")=ASUX("SST")_"0000"
S X=$O(ASUU("USR","")) Q:X']""
I X="*ALL*" D
.;WAR 4/19/2000 added IF statement to D ASURO261
.F S ASUX("USR")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUX("USR"))) Q:ASUX("USR")'?1N.N D
..I $E(ASUX("USR"),1,5)=$E(ASUX("SST"),1,5) D ASURO261
E D
.;WAR 4/21/2000 added next line - data entry person choose 'SELECTED
.; USERS', but did not succeed in entering a valid USER code
.I $D(ASUU("USR",ASUX("SST"))) D
..F S ASUX("USR")=$O(ASUU("USR",ASUX("SST"),ASUX("USR"))) Q:ASUX("USR")="" D
...D ASURO261
Q
ASURO261 ;
S ASUMK("E#","REQ")=ASUX("USR")
S ASUMK("E#","IDX")=0
;LMH changed next line 4/2000
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)!(ASUMK("E#","IDX")[999999)!(ASUMK("E#","REQ")'=ASUX("USR"))) D
.Q:$G(^ASUMX(ASUMK("E#","IDX"),0))="" ;LMH 4/2000
.Q:$P(^ASUMX(ASUMK("E#","IDX"),0),U)[999999
.W:ASUC("IDX")#20=0 "."
.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) LMH 4/24/2000
.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")=$P(ASUMX(0),U,2)
.I ASUMS("EOQ","TP")="Y" Q
.I ASUMX("ACC")=1,ASUMX("CAT")="R" Q
.I ASUMX("ACC")=1,ASUMX("CAT")="N" Q
.S ASUX("ACCG")=$S(ASUMX("ACC")=1:1,ASUMX("ACC")=3:3,1:4)
.I ASUMS("SLC")="H" D
..S ASUX("SLC")="H*"
.E D
..I ASUMS("SLC")="R" D
...S ASUX("SLC")="R*"
..E D
...S ASUX("SLC")="Z*"
.I +ASUV("RP26")=2 S ASUX("SLC")=ASUX("SLC")_ASUMX("CAT")
.S ASUX("IDX")=$S(+ASUV("RP26")=3:ASUMK("E#","IDX"),1:ASUMX("DESC")_$E(ASUMK("E#","IDX"),3,8))
.;S ^XTMP("ASUR","R26",ASUX("SST"),ASUX("USR"),ASUX("ACCG"),ASUX("SLC"),ASUX("IDX"))=ASUMK("E#","IDX")_U_ASUMS("E#","STA") ;LMH
.S ^XTMP("ASUR","R26",ASUMS("E#","STA"),ASUX("USR"),ASUX("ACCG"),ASUX("SLC"),ASUX("IDX"))=ASUMK("E#","IDX")_U_ASUMK("E#","STA")
.K X
Q
ASURO260 ; IHS/ITSC/LMH -S.A.M.S. REPORT 26 SORT ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine sorts report 26 extracts into proper sequence so that the
+3 ;report can be formatted and printed.
+4 ;WAR 4/20/2000 - Made several changes. See original code in DEV or ask
+5 ; Lucy Harmon or myself for hard copy.
+6 SET ASUNW(4)=ASUV("RP26")
+7 SET X=$ORDER(ASUU("SST",""))
IF X']""
QUIT
+8 ;WAR 4/20/2000
SET (ASUMK("E#","STA"),ASUX("STA"))=ASUL(2,"STA","E#")
+9 SET (ASUXSST,ASUX("SST"))=0
+10 ;WAR 4/19/2000 Note:this is SUBstations not Stations.
IF X="*ALL*"
Begin DoDot:1
+11 FOR
SET ASUXSST=$ORDER(^ASUMK(ASUX("STA"),1,ASUXSST))
IF ASUXSST=""
QUIT
Begin DoDot:2
+12 SET ASUX("SST")=$EXTRACT(ASUXSST,1,5)
+13 DO USER
End DoDot:2
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 FOR
SET ASUX("SST")=$ORDER(ASUU("SST",ASUX("SST")))
IF ASUX("SST")=""
QUIT
Begin DoDot:2
+16 DO USER
End DoDot:2
End DoDot:1
+17 KILL ASUMK,ASUMX,ASUMS,ASUC,ASUU,ASUC,ASUX
+18 QUIT
USER ;
+1 SET ASUX("USR")=ASUX("SST")_"0000"
+2 SET X=$ORDER(ASUU("USR",""))
IF X']""
QUIT
+3 IF X="*ALL*"
Begin DoDot:1
+4 ;WAR 4/19/2000 added IF statement to D ASURO261
+5 FOR
SET ASUX("USR")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUX("USR")))
IF ASUX("USR")'?1N.N
QUIT
Begin DoDot:2
+6 IF $EXTRACT(ASUX("USR"),1,5)=$EXTRACT(ASUX("SST"),1,5)
DO ASURO261
End DoDot:2
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 ;WAR 4/21/2000 added next line - data entry person choose 'SELECTED
+9 ; USERS', but did not succeed in entering a valid USER code
+10 IF $DATA(ASUU("USR",ASUX("SST")))
Begin DoDot:2
+11 FOR
SET ASUX("USR")=$ORDER(ASUU("USR",ASUX("SST"),ASUX("USR")))
IF ASUX("USR")=""
QUIT
Begin DoDot:3
+12 DO ASURO261
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
ASURO261 ;
+1 SET ASUMK("E#","REQ")=ASUX("USR")
+2 SET ASUMK("E#","IDX")=0
+3 ;LMH changed next line 4/2000
+4 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)!(ASUMK("E#","IDX")[999999)!(ASUMK("E#","REQ")'=ASUX("USR")))
QUIT
Begin DoDot:1
+5 ;LMH 4/2000
IF $GET(^ASUMX(ASUMK("E#","IDX"),0))=""
QUIT
+6 IF $PIECE(^ASUMX(ASUMK("E#","IDX"),0),U)[999999
QUIT
+7 IF ASUC("IDX")#20=0
WRITE "."
+8 SET ASUMS("E#","STA")=$GET(ASUL(1,"AR","STA1"))
+9 IF ASUMS("E#","STA")']""
SET ASUMS("E#","STA")=ASUMK("E#","STA")
+10 DO DIS^ASUMDIRM(ASUMS("E#","STA"))
IF Y<0
Begin DoDot:2
+11 SET ASUMS("E#","STA")=$ORDER(^ASUMS("C",ASUMK("E#","IDX"),""))
End DoDot:2
+12 IF '$DATA(^ASUMS("C",ASUMK("E#","IDX"),ASUMS("E#","STA")))
Begin DoDot:2
+13 SET ASUMS("E#","STA")=$ORDER(^ASUMS("C",ASUMK("E#","IDX"),""))
End DoDot:2
+14 IF ASUMS("E#","STA")']""
Begin DoDot:2
+15 ;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) LMH 4/24/2000
End DoDot:2
QUIT
+16 SET ASUMS(2)=^ASUMS(ASUMS("E#","STA"),1,ASUMK("E#","IDX"),2)
+17 SET ASUMX(0)=^ASUMX(ASUMK("E#","IDX"),0)
+18 SET ASUMS("EOQ","TP")=$PIECE(ASUMS(2),U,5)
+19 SET ASUMS("SLC")=$PIECE(ASUMS(2),U)
+20 SET ASUMX("ACC")=$PIECE(ASUMX(0),U,6)
+21 SET ASUMX("CAT")=$PIECE(ASUMX(0),U,8)
+22 SET ASUMX("DESC")=$PIECE(ASUMX(0),U,2)
+23 IF ASUMS("EOQ","TP")="Y"
QUIT
+24 IF ASUMX("ACC")=1
IF ASUMX("CAT")="R"
QUIT
+25 IF ASUMX("ACC")=1
IF ASUMX("CAT")="N"
QUIT
+26 SET ASUX("ACCG")=$SELECT(ASUMX("ACC")=1:1,ASUMX("ACC")=3:3,1:4)
+27 IF ASUMS("SLC")="H"
Begin DoDot:2
+28 SET ASUX("SLC")="H*"
End DoDot:2
+29 IF '$TEST
Begin DoDot:2
+30 IF ASUMS("SLC")="R"
Begin DoDot:3
+31 SET ASUX("SLC")="R*"
End DoDot:3
+32 IF '$TEST
Begin DoDot:3
+33 SET ASUX("SLC")="Z*"
End DoDot:3
End DoDot:2
+34 IF +ASUV("RP26")=2
SET ASUX("SLC")=ASUX("SLC")_ASUMX("CAT")
+35 SET ASUX("IDX")=$SELECT(+ASUV("RP26")=3:ASUMK("E#","IDX"),1:ASUMX("DESC")_$EXTRACT(ASUMK("E#","IDX"),3,8))
+36 ;S ^XTMP("ASUR","R26",ASUX("SST"),ASUX("USR"),ASUX("ACCG"),ASUX("SLC"),ASUX("IDX"))=ASUMK("E#","IDX")_U_ASUMS("E#","STA") ;LMH
+37 SET ^XTMP("ASUR","R26",ASUMS("E#","STA"),ASUX("USR"),ASUX("ACCG"),ASUX("SLC"),ASUX("IDX"))=ASUMK("E#","IDX")_U_ASUMK("E#","STA")
+38 KILL X
End DoDot:1
+39 QUIT
