Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ASURO26A

ASURO26A.m

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