ASURO26P ; IHS/ITSC/LMH -PRE-PRINTED ISSUE BOOK-STOCK ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 26, Pre-Printed Issue Book -
;Stock Issues Request Report.
D INIT
S ASUK("PTR")="I/B",%ZIS("A")="Select Printer for Issue Book: " D ^ASUUZIS Q:POP ; JDH quit to %ZIS Q:$D(DUOUT) Q:$D(DTOUT)
D SELMONTH Q:$D(DUOUT) Q:$D(DTOUT)
I ASUK("I/B","Q")=1 D Q
.S XBRP="PSER^ASURO26P",XBRC="^ASURO260",XBRX="^ASUROUKIL" D Q^ASUUZIS K ASUK
D ^ASURO260 ;SORT AND EXTRACT DFNS
D O^ASUUZIS G PSER
PRINT ;EP ;TO RE-CREATE REPORT FROM PREVIOUSLY SELECTED RECORDS
D INIT
D:'$D(DT) ^XBKVAR
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^ASURO26P",ZTDESC="SAMS RPT 26" D O^ASUUZIS
I POP S IOP=$I D ^%ZIS Q
I ASUK(ASUK("PTR"),"Q") G K
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
K ASUX
D U^ASUUZIS
S ASUK("AS OF")=$P($G(^XTMP("ASUR","R26",0)),U,3)
S ASUX("STA")=$O(^XTMP("ASUR","R26",0))
I ASUX("STA")']""!(ASUK("AS OF")']"") D G K
.W @IOF,!!,"NO ISSUE BOOK DATA FOR YOUR SELECTION"
D:'$D(ASULMN) MOTBL
S (ASUC("LN"),ASUC("PG"))=0,ASUC("LI")=""
S ASUX("USR")="" ;LMH 3/9/00
I '$D(ASUX("STA")) S ASUX("STA")=$G(ASUL(2,"STA","E#"))
Q:ASUX("STA")']"" D Q:$D(DUOUT)
.;*LMH* 3/9/00 F S ASUX("USR")=$O(^XTMP("ASUR","R26",ASUX("STA"),$G(ASUX("USR")))) Q:ASUX("USR")']"" D Q:$D(DUOUT)
.F S ASUX("USR")=$O(^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"))) Q:ASUX("USR")']"" D Q:$D(DUOUT) ;LMH - above $G was not re-setting user below.
..S ASUMY("USR")=ASUX("USR")
..S ASUC("PG")=0
..F S ASUX("ACC")=$O(^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"),$G(ASUX("ACC")))) Q:ASUX("ACC")']"" D Q:$D(DUOUT)
...F S ASUX("SLCCAT")=$O(^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"),ASUX("ACC"),$G(ASUX("SLCCAT")))) Q:ASUX("SLCCAT")']"" D Q:$D(DUOUT)
....S ASUF("PGBK")=2
....F S ASUX("IDX")=$O(^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"),ASUX("ACC"),ASUX("SLCCAT"),$G(ASUX("IDX")))) Q:ASUX("IDX")']"" D INDEX Q:$D(DUOUT)
....W !,"TOTAL LINE ITEMS: ",$J($FN(ASUC("LI"),","),10)
....S ASUC("LI")=0
...K ASUL(20),ASUL(18) ;WAR 4/19/2000 - added ASUL(18)
D CLS^ASUUHDG
K ;
K %DT,ASU,ASUC,ASUF,ASUV,ASUX,ASUMX,ASUMB,ASUMS
K ASULMN,ASULMO,ASUQ("MO"),X,X1,X2,X3,X4
F X=3:1:22 K ASUL(X) ;Clear Table Lookup fields
D PAZ^ASUURHDR I $G(ASUK("PTRSEL"))]"" W @IOF Q
D C^ASUUZIS
Q
INDEX ;
S ASUC("LI")=ASUC("LI")+1
S ASUX(0)=^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"),ASUX("ACC"),ASUX("SLCCAT"),ASUX("IDX"))
S ASUMS("E#","STA")=$P(ASUX(0),U,2)
S (ASUMX("E#","IDX"),ASUMS("E#","IDX"))=$P(ASUX(0),U)
;S ASUMK("E#","STA")=ASUX("STA") ;LMH
S ASUMK("E#","STA")=ASUL(2,"STA","E#") ;LMH 4/13/00
S ASUMK("E#","REQ")=ASUX("USR")
D READ^ASUMXDIO,REQ^ASULDIRR(ASUMK("E#","REQ"))
G:ASUMX("CAT")']"" UNKNOWN
S ASUL(7,"CAT","E#")=$O(^ASUL(7,"B",ASUMX("CAT"),"")) G:ASUL(7,"CAT","E#")']"" UNKNOWN
S ASUL(7,"SOBJ","E#")=$O(^ASUL(7,"D",ASUMX("SOBJ"),ASUL(7,"CAT","E#"),"")) G:ASUL(7,"SOBJ","E#")']"" UNKNOWN
S ASUK("CAT NM")=$P(^ASUL(7,ASUL(7,"CAT","E#"),1,ASUL(7,"SOBJ","E#"),0),U,3) G READMST
UNKNOWN ;
S ASUK("CAT NM")="UNKNOWN CATEGORY"
READMST ;
S ASUMK("E#","IDX")=ASUMX("E#","IDX")
D ^ASUMSTRD,READ^ASUMKBIO
D:ASUF("PGBK")>1 HDPG Q:$D(DUOUT)
D:ASUF("PGBK") HEADER Q:$D(DUOUT)
S (ASUC("TOT","ISS"),ASUC("P6MO","QTY"),ASUC("P6MO","DOC"),ASUC("TOT","DOC"),ASUF("SESNL"))=0
F ASUU(17)=0:1:11 D
.S ASUQ("MO")=ASUK("AS OF")+ASUU(17)
.S:ASUQ("MO")>12 ASUQ("MO")=ASUQ("MO")-12
.S ASULMO(ASUU(17)+1)=ASUQ("MO")
.I ASUU(17)>5 D
..S ASUC("P6MO","QTY")=ASUC("P6MO","QTY")+ASUMK(ASUQ("MO"),"QTY")
..S ASUC("P6MO","DOC")=ASUC("P6MO","DOC")+ASUMK(ASUQ("MO"),"DOC")
.S ASUC("TOT","ISS")=ASUC("TOT","ISS")+ASUMK(ASUQ("MO"),"QTY")
.S ASUC("TOT","DOC")=ASUC("TOT","DOC")+ASUMK(ASUQ("MO"),"DOC")
I ASUC("TOT","ISS")=0,+ASUMK("ULQTY")'>0 Q
W !,$E(ASUMX("IDX"),1,5),".",$E(ASUMX("IDX"),6,6)
W ?10,ASUMS("SLC")
W ?13,$E(ASUMX("DESC"),1,30)
W ?47,ASUMX("AR U/I")
I ASUMK("ULQTY")?1N.N D
.W ?52,ASUMK("ULQTY"),"**"
E D
.S Y=$E(ASUMS("ESTB"),1,3)+1700
.S Y=ASUK("DT","YEAR")-Y
.S X=$E(ASUMS("ESTB"),4,5)
.S X=ASUK("DT","MO")-X
.S ASUV("MOLD")=(Y*12)+X
.K X,Y
.S:ASUV("MOLD")>6 ASUV("MOLD")=6
.S ASUV("ULVQTY")=$FN(ASUC("P6MO","QTY")/ASUV("MOLD"),"",0)
.I ASUMS("EOQ","TP")="Q" D
..S ASUF("SESNL")=1
.S ASUV("ULVQTY")=$FN(ASUV("ULVQTY")*ASUL(20,"ULVQ FCTR"),"",0)
.W ?52,$J($FN(ASUV("ULVQTY"),"-",0),7)
I ASUMS("QTY","O/H")=0!(ASUMS("QTY","O/H")="") D
.S ASUV("CST/U")=ASUMS("LPP")
E D
.S ASUV("CST/U")=$FN((ASUMS("VAL","O/H")/ASUMS("QTY","O/H")),"",2)
W ?58,$J($FN(ASUV("CST/U"),",",2),8)
W ?65,$J($FN(ASUC("P6MO","QTY"),",",0),6)
W ?74,ASUC("P6MO","DOC")
W !?13,$E(ASUMX("DESC"),31,60)
I ASUF("SESNL") W ?51,"SEASONAL ITEM" S ASUF("SESNL")=0
W !
F ASUU(17)=1:1:6 D
.S ASUU(18)=ASULMO(ASUU(17))
.W $E(ASULMN(ASUU(18)))," PYIQ "
.W $J($FN(ASUMK(ASUU(18),"QTY"),",",0),5)," "
W !
F ASUU(17)=1:1:6 D
.S ASUU(18)=ASULMO(ASUU(17))
.W $E(ASULMN(ASUU(18)),2,2)," Q-OH..... "
W !
F ASUU(17)=1:1:6 D
.S ASUU(18)=ASULMO(ASUU(17))
.W $E(ASULMN(ASUU(18)),3,3)," ORDQ..... "
W !!
S ASUC("LN")=ASUC("LN")+6 D:ASUC("LN")>(IOSL-2) HEADER Q:$D(DUOUT)
Q
INIT ;
D:$G(ASUK("DT","FM"))']"" DATE^ASUUDATE
D:$G(ASUL(1,"AR","AP"))']"" SETAREA^ASULARST
I '$D(IO) D HOME^%ZIS
Q
SELMONTH ;
S ASULMN(1)="JANUARY",ASULMN(2)="FEBRUARY",ASULMN(3)="MARCH"
S ASULMN(4)="APRIL",ASULMN(5)="MAY",ASULMN(6)="JUNE"
S ASULMN(7)="JULY",ASULMN(8)="AUGUST",ASULMN(9)="SEPTEMBER"
S ASULMN(10)="OCTOBER",ASULMN(11)="NOVEMBER",ASULMN(12)="DECEMBER"
S ASUK("AS OF")="",ASUV("COL")=1 W !,"Select one of the following:",!!
F ASUK("AS OF")=1:1:12 D
.W ?ASUV("COL"),ASUK("AS OF"),": ",ASULMN(ASUK("AS OF"))
.S ASUV("COL")=$S(ASUV("COL")=61:1,1:ASUV("COL")+20)
.W:ASUV("COL")=1 !
W !
S DIR(0)="N:1,12,0",DIR("A")="Select Month Issue Book to begin with "
S DIR("?")="Select a number from 1 -12",DIR("B")=+$E(ASUK("DT","FM"),4,5)+1 S:DIR("B")=13 DIR("B")=1
D ^DIR K DIR Q:$D(DIRUT) Q:$D(DTOUT) Q:$D(DUOUT)
S ASUK("AS OF")=X
K ^XTMP("ASUR","R26")
S ^XTMP("ASUR","R26",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")_U_$G(ASUK("AS OF"))
;S ^XTMP("ASUR","R26",0)=$G(ASUK("AS OF"))
D SETAREA^ASULARST
K ASUF("QU")
S ASUF("BK")=0
F ASUU(10)=1:1:3 W !,ASUU(10)," ",$P($T(@ASUU(10)),";",3)
S DIR(0)="L^1:3:0^S ASUV(""RP26"")=Y",DIR("A")="ENTER SELECTION "
W ! D ^DIR
;W X
S:X["^" ASUF("QU")=1
Q:$D(ASUF("QU"))
K ASUU("SST")
D SST^ASURO26A I $D(ASUF("QU")) K ASUF("QU") Q
D USR^ASURO26A I $D(ASUF("QU")) K ASUF("QU") Q
Q
1 ;;ISSUE BOOK -ALPHA SEQ BY SUB STATION AND USER
2 ;;ISSUE BOOK -ALPHA SEQ BY CATEGORY
3 ;;ISSUE BOOK -INDEX SEQ
S ASUC("PG")=ASUC("PG")+1,ASUC("LN")=7,ASUF("PGBK")=0
D:ASUC("PG")>1 PAZ^ASUURHDR Q:$D(DUOUT) W @IOF
S X=ASUL(1,"AR","AP") D AREA^ASULARST
S X1=ASUMS("E#","STA") D STAT^ASULARST
W !?1,"REPORT #26 PREPRINTED ISSUE BOOK -STOCK ISSUE REQUEST",?70,"PAGE: ",ASUC("PG")
W !?1,"AREA: ",ASUL(1,"AR","AP"),?10,ASUL(1,"AR","NM"),?33,"STATION: ",ASUL(2,"STA","CD"),?45,ASUL(2,"STA","NM")
W !?1,"SUBSTATION: ",ASUMK("SST")," ",ASUMK("SST","NM"),?33,"USER CODE: ",$E(ASUMY("USR"),6,7)_$E(ASUMY("USR"),9) ;**LMH**3/9/00," ",ASUMK("USR","NM")
W:$P(ASUX("SLCCAT"),"*")="R" ?63," SLC : REFRIGERATE"
W:$P(ASUX("SLCCAT"),"*")="H" ?63," SLC : HAZARDOUS"
W:$P(ASUX("SLCCAT"),"*")="Z" ?63," SLC : ALL OTHERS"
W !?5,"ACCOUNT : ",$S(ASUX("ACC")=1:"PHARMACY",ASUX("ACC")=3:"SUBSISTENCE",1:"ALL OTHER")
W:$P(ASUX("SLCCAT"),"*",2)]"" ?37," CATEGORY : ",ASUMX("CAT")," -",ASUK("CAT NM")
W !!?3,"INDEX S",?54,"USER",?61,"UNIT PREV 6-MOS"
W !?2,"NUMBER L DESCRIPTION",?47,"UI",?53,"LEVEL",?61,"COST QTY DOC",!
Q
HDPG ;EP; -COVER PAGE FOR EACH CATEGORY
D PAZ^ASUURHDR
D CLS^ASUUHDG
S X=ASUL(1,"AR","AP") D AREA^ASULARST S X1=ASUMS("STA") D STAT^ASULARST
W !?1,"REPORT #26 RECORD OF RECEIPT FOR SUPPLIES (HEW-394C -USE WITH 394A)"
W !?1,"AREA: ",ASUL(1,"AR","AP"),?10,ASUL(1,"AR","NM"),?33,"STATION: ",ASUL(2,"STA","CD"),?46,ASUL(2,"STA","NM")
W !?1,"SUBSTATION: ",ASUMK("SST")," ",ASUMK("SST","NM"),?33,"USER CODE: ",$E(ASUMY("USR"),6,7)_$E(ASUMY("USR"),9) ; ** LMH ** 3/9/00 ," ",ASUMK("USR","NM")
W:$P(ASUX("SLCCAT"),"*")="R" ?63," SLC : REFRIGERATE"
W:$P(ASUX("SLCCAT"),"*")="H" ?63," SLC : HAZARDOUS"
W:$P(ASUX("SLCCAT"),"*")="Z" ?63," SLC : ALL OTHERS"
W !?5,"ACCOUNT : ",$S(ASUX("ACC")=1:"PHARMACY",ASUX("ACC")=3:"SUBSISTENCE",1:"ALL OTHER")
W:$P(ASUX("SLCCAT"),"*",2)]"" ?37," CATEGORY : ",ASUMX("CAT")," -",ASUK("CAT NM")
W !!?1,"SUPPLIES FOR",!?1,"THE MONTH OF",?17,"REQUESTED BY",?37,"ISSUED BY",?57,"RECIEVED BY **"
F ASUU(19)=0:1:5 S ASUV("ASOF")=ASUK("AS OF")+ASUU(19) S:ASUV("ASOF")>12 ASUV("ASOF")=ASUV("ASOF")-12 D PRTMOS
K ASUV("ASOF"),ASUU(19)
Q
PRTMOS ;
W !!!!!?1,ASULMN(ASUV("ASOF")),!?17,"(SIGNATURE & DATE)",?37,"(SIGNATURE & DATE)",?57,"(SIGNATURE & DATE)",!?7,"VOUCHER NUMBER: ",?37,"VOUCHER DATE"
Q
SELAOMO ;
D MOTBL
S ASUK("AS OF")="",ASUV("COL")=1 W !,"Select one of the following:",!!
F ASUK("AS OF")=1:1:12 D
.W ?ASUV("COL"),ASUK("AS OF"),": ",ASULMN(ASUK("AS OF"))
.S ASUV("COL")=$S(ASUV("COL")=61:1,1:ASUV("COL")+20)
.W:ASUV("COL")=1 !
W !
S DIR(0)="N:1,12,0",DIR("A")="Select Month Issue Book to begin with "
S DIR("?")="Select a number from 1 -12",DIR("B")=+$E(DT,4,5)+1 S:DIR("B")=13 DIR("B")=1
D ^DIR K DIR Q:$D(DIRUT)
S ASUK("AS OF")=X
Q
MOTBL ;
S ASULMN(1)="JANUARY",ASULMN(2)="FEBRUARY",ASULMN(3)="MARCH"
S ASULMN(4)="APRIL",ASULMN(5)="MAY",ASULMN(6)="JUNE"
S ASULMN(7)="JULY",ASULMN(8)="AUGUST",ASULMN(9)="SEPTEMBER"
S ASULMN(10)="OCTOBER",ASULMN(11)="NOVEMBER",ASULMN(12)="DECEMBER"
Q
ASURO26P ; IHS/ITSC/LMH -PRE-PRINTED ISSUE BOOK-STOCK ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 26, Pre-Printed Issue Book -
+3 ;Stock Issues Request Report.
+4 DO INIT
+5 ; JDH quit to %ZIS Q:$D(DUOUT) Q:$D(DTOUT)
SET ASUK("PTR")="I/B"
SET %ZIS("A")="Select Printer for Issue Book: "
DO ^ASUUZIS
IF POP
QUIT
+6 DO SELMONTH
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+7 IF ASUK("I/B","Q")=1
Begin DoDot:1
+8 SET XBRP="PSER^ASURO26P"
SET XBRC="^ASURO260"
SET XBRX="^ASUROUKIL"
DO Q^ASUUZIS
KILL ASUK
End DoDot:1
QUIT
+9 ;SORT AND EXTRACT DFNS
DO ^ASURO260
+10 DO O^ASUUZIS
GOTO PSER
PRINT ;EP ;TO RE-CREATE REPORT FROM PREVIOUSLY SELECTED RECORDS
+1 DO INIT
+2 IF '$DATA(DT)
DO ^XBKVAR
+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"))
IF ASUK("PTRSEL")]""
GOTO PSER
+6 SET ZTRTN="PSER^ASURO26P"
SET ZTDESC="SAMS RPT 26"
DO O^ASUUZIS
+7 IF POP
SET IOP=$IO
DO ^%ZIS
QUIT
+8 IF ASUK(ASUK("PTR"),"Q")
GOTO K
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
+1 KILL ASUX
+2 DO U^ASUUZIS
+3 SET ASUK("AS OF")=$PIECE($GET(^XTMP("ASUR","R26",0)),U,3)
+4 SET ASUX("STA")=$ORDER(^XTMP("ASUR","R26",0))
+5 IF ASUX("STA")']""!(ASUK("AS OF")']"")
Begin DoDot:1
+6 WRITE @IOF,!!,"NO ISSUE BOOK DATA FOR YOUR SELECTION"
End DoDot:1
GOTO K
+7 IF '$DATA(ASULMN)
DO MOTBL
+8 SET (ASUC("LN"),ASUC("PG"))=0
SET ASUC("LI")=""
+9 ;LMH 3/9/00
SET ASUX("USR")=""
+10 IF '$DATA(ASUX("STA"))
SET ASUX("STA")=$GET(ASUL(2,"STA","E#"))
+11 IF ASUX("STA")']""
QUIT
Begin DoDot:1
+12 ;*LMH* 3/9/00 F S ASUX("USR")=$O(^XTMP("ASUR","R26",ASUX("STA"),$G(ASUX("USR")))) Q:ASUX("USR")']"" D Q:$D(DUOUT)
+13 ;LMH - above $G was not re-setting user below.
FOR
SET ASUX("USR")=$ORDER(^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR")))
IF ASUX("USR")']""
QUIT
Begin DoDot:2
+14 SET ASUMY("USR")=ASUX("USR")
+15 SET ASUC("PG")=0
+16 FOR
SET ASUX("ACC")=$ORDER(^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"),$GET(ASUX("ACC"))))
IF ASUX("ACC")']""
QUIT
Begin DoDot:3
+17 FOR
SET ASUX("SLCCAT")=$ORDER(^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"),ASUX("ACC"),$GET(ASUX("SLCCAT"))))
IF ASUX("SLCCAT")']""
QUIT
Begin DoDot:4
+18 SET ASUF("PGBK")=2
+19 FOR
SET ASUX("IDX")=$ORDER(^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"),ASUX("ACC"),ASUX("SLCCAT"),$GET(ASUX("IDX"))))
IF ASUX("IDX")']""
QUIT
DO INDEX
IF $DATA(DUOUT)
QUIT
+20 WRITE !,"TOTAL LINE ITEMS: ",$JUSTIFY($FNUMBER(ASUC("LI"),","),10)
+21 SET ASUC("LI")=0
End DoDot:4
IF $DATA(DUOUT)
QUIT
+22 ;WAR 4/19/2000 - added ASUL(18)
KILL ASUL(20),ASUL(18)
End DoDot:3
IF $DATA(DUOUT)
QUIT
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
IF $DATA(DUOUT)
QUIT
+23 DO CLS^ASUUHDG
K ;
+1 KILL %DT,ASU,ASUC,ASUF,ASUV,ASUX,ASUMX,ASUMB,ASUMS
+2 KILL ASULMN,ASULMO,ASUQ("MO"),X,X1,X2,X3,X4
+3 ;Clear Table Lookup fields
FOR X=3:1:22
KILL ASUL(X)
+4 DO PAZ^ASUURHDR
IF $GET(ASUK("PTRSEL"))]""
WRITE @IOF
QUIT
+5 DO C^ASUUZIS
+6 QUIT
INDEX ;
+1 SET ASUC("LI")=ASUC("LI")+1
+2 SET ASUX(0)=^XTMP("ASUR","R26",ASUX("STA"),ASUX("USR"),ASUX("ACC"),ASUX("SLCCAT"),ASUX("IDX"))
+3 SET ASUMS("E#","STA")=$PIECE(ASUX(0),U,2)
+4 SET (ASUMX("E#","IDX"),ASUMS("E#","IDX"))=$PIECE(ASUX(0),U)
+5 ;S ASUMK("E#","STA")=ASUX("STA") ;LMH
+6 ;LMH 4/13/00
SET ASUMK("E#","STA")=ASUL(2,"STA","E#")
+7 SET ASUMK("E#","REQ")=ASUX("USR")
+8 DO READ^ASUMXDIO
DO REQ^ASULDIRR(ASUMK("E#","REQ"))
+9 IF ASUMX("CAT")']""
GOTO UNKNOWN
+10 SET ASUL(7,"CAT","E#")=$ORDER(^ASUL(7,"B",ASUMX("CAT"),""))
IF ASUL(7,"CAT","E#")']""
GOTO UNKNOWN
+11 SET ASUL(7,"SOBJ","E#")=$ORDER(^ASUL(7,"D",ASUMX("SOBJ"),ASUL(7,"CAT","E#"),""))
IF ASUL(7,"SOBJ","E#")']""
GOTO UNKNOWN
+12 SET ASUK("CAT NM")=$PIECE(^ASUL(7,ASUL(7,"CAT","E#"),1,ASUL(7,"SOBJ","E#"),0),U,3)
GOTO READMST
UNKNOWN ;
+1 SET ASUK("CAT NM")="UNKNOWN CATEGORY"
READMST ;
+1 SET ASUMK("E#","IDX")=ASUMX("E#","IDX")
+2 DO ^ASUMSTRD
DO READ^ASUMKBIO
+3 IF ASUF("PGBK")>1
DO HDPG
IF $DATA(DUOUT)
QUIT
+4 IF ASUF("PGBK")
DO HEADER
IF $DATA(DUOUT)
QUIT
+5 SET (ASUC("TOT","ISS"),ASUC("P6MO","QTY"),ASUC("P6MO","DOC"),ASUC("TOT","DOC"),ASUF("SESNL"))=0
+6 FOR ASUU(17)=0:1:11
Begin DoDot:1
+7 SET ASUQ("MO")=ASUK("AS OF")+ASUU(17)
+8 IF ASUQ("MO")>12
SET ASUQ("MO")=ASUQ("MO")-12
+9 SET ASULMO(ASUU(17)+1)=ASUQ("MO")
+10 IF ASUU(17)>5
Begin DoDot:2
+11 SET ASUC("P6MO","QTY")=ASUC("P6MO","QTY")+ASUMK(ASUQ("MO"),"QTY")
+12 SET ASUC("P6MO","DOC")=ASUC("P6MO","DOC")+ASUMK(ASUQ("MO"),"DOC")
End DoDot:2
+13 SET ASUC("TOT","ISS")=ASUC("TOT","ISS")+ASUMK(ASUQ("MO"),"QTY")
+14 SET ASUC("TOT","DOC")=ASUC("TOT","DOC")+ASUMK(ASUQ("MO"),"DOC")
End DoDot:1
+15 IF ASUC("TOT","ISS")=0
IF +ASUMK("ULQTY")'>0
QUIT
+16 WRITE !,$EXTRACT(ASUMX("IDX"),1,5),".",$EXTRACT(ASUMX("IDX"),6,6)
+17 WRITE ?10,ASUMS("SLC")
+18 WRITE ?13,$EXTRACT(ASUMX("DESC"),1,30)
+19 WRITE ?47,ASUMX("AR U/I")
+20 IF ASUMK("ULQTY")?1N.N
Begin DoDot:1
+21 WRITE ?52,ASUMK("ULQTY"),"**"
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 SET Y=$EXTRACT(ASUMS("ESTB"),1,3)+1700
+24 SET Y=ASUK("DT","YEAR")-Y
+25 SET X=$EXTRACT(ASUMS("ESTB"),4,5)
+26 SET X=ASUK("DT","MO")-X
+27 SET ASUV("MOLD")=(Y*12)+X
+28 KILL X,Y
+29 IF ASUV("MOLD")>6
SET ASUV("MOLD")=6
+30 SET ASUV("ULVQTY")=$FNUMBER(ASUC("P6MO","QTY")/ASUV("MOLD"),"",0)
+31 IF ASUMS("EOQ","TP")="Q"
Begin DoDot:2
+32 SET ASUF("SESNL")=1
End DoDot:2
+33 SET ASUV("ULVQTY")=$FNUMBER(ASUV("ULVQTY")*ASUL(20,"ULVQ FCTR"),"",0)
+34 WRITE ?52,$JUSTIFY($FNUMBER(ASUV("ULVQTY"),"-",0),7)
End DoDot:1
+35 IF ASUMS("QTY","O/H")=0!(ASUMS("QTY","O/H")="")
Begin DoDot:1
+36 SET ASUV("CST/U")=ASUMS("LPP")
End DoDot:1
+37 IF '$TEST
Begin DoDot:1
+38 SET ASUV("CST/U")=$FNUMBER((ASUMS("VAL","O/H")/ASUMS("QTY","O/H")),"",2)
End DoDot:1
+39 WRITE ?58,$JUSTIFY($FNUMBER(ASUV("CST/U"),",",2),8)
+40 WRITE ?65,$JUSTIFY($FNUMBER(ASUC("P6MO","QTY"),",",0),6)
+41 WRITE ?74,ASUC("P6MO","DOC")
+42 WRITE !?13,$EXTRACT(ASUMX("DESC"),31,60)
+43 IF ASUF("SESNL")
WRITE ?51,"SEASONAL ITEM"
SET ASUF("SESNL")=0
+44 WRITE !
+45 FOR ASUU(17)=1:1:6
Begin DoDot:1
+46 SET ASUU(18)=ASULMO(ASUU(17))
+47 WRITE $EXTRACT(ASULMN(ASUU(18)))," PYIQ "
+48 WRITE $JUSTIFY($FNUMBER(ASUMK(ASUU(18),"QTY"),",",0),5)," "
End DoDot:1
+49 WRITE !
+50 FOR ASUU(17)=1:1:6
Begin DoDot:1
+51 SET ASUU(18)=ASULMO(ASUU(17))
+52 WRITE $EXTRACT(ASULMN(ASUU(18)),2,2)," Q-OH..... "
End DoDot:1
+53 WRITE !
+54 FOR ASUU(17)=1:1:6
Begin DoDot:1
+55 SET ASUU(18)=ASULMO(ASUU(17))
+56 WRITE $EXTRACT(ASULMN(ASUU(18)),3,3)," ORDQ..... "
End DoDot:1
+57 WRITE !!
+58 SET ASUC("LN")=ASUC("LN")+6
IF ASUC("LN")>(IOSL-2)
DO HEADER
IF $DATA(DUOUT)
QUIT
+59 QUIT
INIT ;
+1 IF $GET(ASUK("DT","FM"))']""
DO DATE^ASUUDATE
+2 IF $GET(ASUL(1,"AR","AP"))']""
DO SETAREA^ASULARST
+3 IF '$DATA(IO)
DO HOME^%ZIS
+4 QUIT
SELMONTH ;
+1 SET ASULMN(1)="JANUARY"
SET ASULMN(2)="FEBRUARY"
SET ASULMN(3)="MARCH"
+2 SET ASULMN(4)="APRIL"
SET ASULMN(5)="MAY"
SET ASULMN(6)="JUNE"
+3 SET ASULMN(7)="JULY"
SET ASULMN(8)="AUGUST"
SET ASULMN(9)="SEPTEMBER"
+4 SET ASULMN(10)="OCTOBER"
SET ASULMN(11)="NOVEMBER"
SET ASULMN(12)="DECEMBER"
+5 SET ASUK("AS OF")=""
SET ASUV("COL")=1
WRITE !,"Select one of the following:",!!
+6 FOR ASUK("AS OF")=1:1:12
Begin DoDot:1
+7 WRITE ?ASUV("COL"),ASUK("AS OF"),": ",ASULMN(ASUK("AS OF"))
+8 SET ASUV("COL")=$SELECT(ASUV("COL")=61:1,1:ASUV("COL")+20)
+9 IF ASUV("COL")=1
WRITE !
End DoDot:1
+10 WRITE !
+11 SET DIR(0)="N:1,12,0"
SET DIR("A")="Select Month Issue Book to begin with "
+12 SET DIR("?")="Select a number from 1 -12"
SET DIR("B")=+$EXTRACT(ASUK("DT","FM"),4,5)+1
IF DIR("B")=13
SET DIR("B")=1
+13 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
+14 SET ASUK("AS OF")=X
+15 KILL ^XTMP("ASUR","R26")
+16 SET ^XTMP("ASUR","R26",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")_U_$GET(ASUK("AS OF"))
+17 ;S ^XTMP("ASUR","R26",0)=$G(ASUK("AS OF"))
+18 DO SETAREA^ASULARST
+19 KILL ASUF("QU")
+20 SET ASUF("BK")=0
+21 FOR ASUU(10)=1:1:3
WRITE !,ASUU(10)," ",$PIECE($TEXT(@ASUU(10)),";",3)
+22 SET DIR(0)="L^1:3:0^S ASUV(""RP26"")=Y"
SET DIR("A")="ENTER SELECTION "
+23 WRITE !
DO ^DIR
+24 ;W X
+25 IF X["^"
SET ASUF("QU")=1
+26 IF $DATA(ASUF("QU"))
QUIT
+27 KILL ASUU("SST")
+28 DO SST^ASURO26A
IF $DATA(ASUF("QU"))
KILL ASUF("QU")
QUIT
+29 DO USR^ASURO26A
IF $DATA(ASUF("QU"))
KILL ASUF("QU")
QUIT
+30 QUIT
1 ;;ISSUE BOOK -ALPHA SEQ BY SUB STATION AND USER
2 ;;ISSUE BOOK -ALPHA SEQ BY CATEGORY
3 ;;ISSUE BOOK -INDEX SEQ
+1 SET ASUC("PG")=ASUC("PG")+1
SET ASUC("LN")=7
SET ASUF("PGBK")=0
+2 IF ASUC("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
WRITE @IOF
+3 SET X=ASUL(1,"AR","AP")
DO AREA^ASULARST
+4 SET X1=ASUMS("E#","STA")
DO STAT^ASULARST
+5 WRITE !?1,"REPORT #26 PREPRINTED ISSUE BOOK -STOCK ISSUE REQUEST",?70,"PAGE: ",ASUC("PG")
+6 WRITE !?1,"AREA: ",ASUL(1,"AR","AP"),?10,ASUL(1,"AR","NM"),?33,"STATION: ",ASUL(2,"STA","CD"),?45,ASUL(2,"STA","NM")
+7 ;**LMH**3/9/00," ",ASUMK("USR","NM")
WRITE !?1,"SUBSTATION: ",ASUMK("SST")," ",ASUMK("SST","NM"),?33,"USER CODE: ",$EXTRACT(ASUMY("USR"),6,7)_$EXTRACT(ASUMY("USR"),9)
+8 IF $PIECE(ASUX("SLCCAT"),"*")="R"
WRITE ?63," SLC : REFRIGERATE"
+9 IF $PIECE(ASUX("SLCCAT"),"*")="H"
WRITE ?63," SLC : HAZARDOUS"
+10 IF $PIECE(ASUX("SLCCAT"),"*")="Z"
WRITE ?63," SLC : ALL OTHERS"
+11 WRITE !?5,"ACCOUNT : ",$SELECT(ASUX("ACC")=1:"PHARMACY",ASUX("ACC")=3:"SUBSISTENCE",1:"ALL OTHER")
+12 IF $PIECE(ASUX("SLCCAT"),"*",2)]""
WRITE ?37," CATEGORY : ",ASUMX("CAT")," -",ASUK("CAT NM")
+13 WRITE !!?3,"INDEX S",?54,"USER",?61,"UNIT PREV 6-MOS"
+14 WRITE !?2,"NUMBER L DESCRIPTION",?47,"UI",?53,"LEVEL",?61,"COST QTY DOC",!
+15 QUIT
HDPG ;EP; -COVER PAGE FOR EACH CATEGORY
+1 DO PAZ^ASUURHDR
+2 DO CLS^ASUUHDG
+3 SET X=ASUL(1,"AR","AP")
DO AREA^ASULARST
SET X1=ASUMS("STA")
DO STAT^ASULARST
+4 WRITE !?1,"REPORT #26 RECORD OF RECEIPT FOR SUPPLIES (HEW-394C -USE WITH 394A)"
+5 WRITE !?1,"AREA: ",ASUL(1,"AR","AP"),?10,ASUL(1,"AR","NM"),?33,"STATION: ",ASUL(2,"STA","CD"),?46,ASUL(2,"STA","NM")
+6 ; ** LMH ** 3/9/00 ," ",ASUMK("USR","NM")
WRITE !?1,"SUBSTATION: ",ASUMK("SST")," ",ASUMK("SST","NM"),?33,"USER CODE: ",$EXTRACT(ASUMY("USR"),6,7)_$EXTRACT(ASUMY("USR"),9)
+7 IF $PIECE(ASUX("SLCCAT"),"*")="R"
WRITE ?63," SLC : REFRIGERATE"
+8 IF $PIECE(ASUX("SLCCAT"),"*")="H"
WRITE ?63," SLC : HAZARDOUS"
+9 IF $PIECE(ASUX("SLCCAT"),"*")="Z"
WRITE ?63," SLC : ALL OTHERS"
+10 WRITE !?5,"ACCOUNT : ",$SELECT(ASUX("ACC")=1:"PHARMACY",ASUX("ACC")=3:"SUBSISTENCE",1:"ALL OTHER")
+11 IF $PIECE(ASUX("SLCCAT"),"*",2)]""
WRITE ?37," CATEGORY : ",ASUMX("CAT")," -",ASUK("CAT NM")
+12 WRITE !!?1,"SUPPLIES FOR",!?1,"THE MONTH OF",?17,"REQUESTED BY",?37,"ISSUED BY",?57,"RECIEVED BY **"
+13 FOR ASUU(19)=0:1:5
SET ASUV("ASOF")=ASUK("AS OF")+ASUU(19)
IF ASUV("ASOF")>12
SET ASUV("ASOF")=ASUV("ASOF")-12
DO PRTMOS
+14 KILL ASUV("ASOF"),ASUU(19)
+15 QUIT
PRTMOS ;
+1 WRITE !!!!!?1,ASULMN(ASUV("ASOF")),!?17,"(SIGNATURE & DATE)",?37,"(SIGNATURE & DATE)",?57,"(SIGNATURE & DATE)",!?7,"VOUCHER NUMBER: ",?37,"VOUCHER DATE"
+2 QUIT
SELAOMO ;
+1 DO MOTBL
+2 SET ASUK("AS OF")=""
SET ASUV("COL")=1
WRITE !,"Select one of the following:",!!
+3 FOR ASUK("AS OF")=1:1:12
Begin DoDot:1
+4 WRITE ?ASUV("COL"),ASUK("AS OF"),": ",ASULMN(ASUK("AS OF"))
+5 SET ASUV("COL")=$SELECT(ASUV("COL")=61:1,1:ASUV("COL")+20)
+6 IF ASUV("COL")=1
WRITE !
End DoDot:1
+7 WRITE !
+8 SET DIR(0)="N:1,12,0"
SET DIR("A")="Select Month Issue Book to begin with "
+9 SET DIR("?")="Select a number from 1 -12"
SET DIR("B")=+$EXTRACT(DT,4,5)+1
IF DIR("B")=13
SET DIR("B")=1
+10 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+11 SET ASUK("AS OF")=X
+12 QUIT
MOTBL ;
+1 SET ASULMN(1)="JANUARY"
SET ASULMN(2)="FEBRUARY"
SET ASULMN(3)="MARCH"
+2 SET ASULMN(4)="APRIL"
SET ASULMN(5)="MAY"
SET ASULMN(6)="JUNE"
+3 SET ASULMN(7)="JULY"
SET ASULMN(8)="AUGUST"
SET ASULMN(9)="SEPTEMBER"
+4 SET ASULMN(10)="OCTOBER"
SET ASULMN(11)="NOVEMBER"
SET ASULMN(12)="DECEMBER"
+5 QUIT
