3:04 PM  15-APR-98
SAMS patch 2
ASUADCOR
ASUADCOR ;DSD/DFM - DUE IN CORRECTION;  [ 04/15/98  2:31 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
 F  Q:$G(ASUREPLY("CORRECT"))="Y"  Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  D
 .Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  Q:ASUREPLY("CORRECT")="Y"
 .S DIR(0)="SB^Y:YES;N:NO;3:STATION;4:PURCHASE ORDER NUMBER;5:DATE DUE IN;6:ACCOUNT;7:SUB SUB ACTIVITY;8:INDEX;9:QUANTITY;10:VALUE"
 .D CORRECT^ASUAUYRN Q:ASUREPLY("CORRECT")="Y"  D
 ..D:ASUREPLY("CORRECT")="N"
 ...S DIR(0)="NOA^3:10:0"
 ...D GETFIELD^ASUAUYRN
 ..Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  Q:ASUREPLY("CORRECT")="Y"
 ..I ASUREPLY("CORRECT")="3" S DIR("B")=ASUTRNS(ASUTRNS,"STATION"),ASUTRNS(ASUTRNS,"STATION")="" D STAT^ASUAUAST
 ..I ASUREPLY("CORRECT")="4" D REQD^ASUAUPON
 ..I $E(ASUTRNS("TRANSACTION CODE"),2,2)'?1N I ASUREPLY("CORRECT")=5 S ASUV("ITEM #")=5 D ^ASUAUIDX
 ..I ASUREPLY("CORRECT")="5" D ^ASUADTDU
 ..I ASUREPLY("CORRECT")="6" S ASUV("ITEM #")=6 D ^ASUAUACC
 ..I ASUREPLY("CORRECT")="7" S ASUV("ITEM #")=7 D ^ASUAUSSA
 ..I ASUREPLY("CORRECT")="8" S ASUV("ITEM #")=8 D ^ASUAUIDX
 ..I ASUREPLY("CORRECT")="9" S ASUV("ITEM #")=9 D ^ASUAUQTY
 ..I ASUREPLY("CORRECT")="10" S ASUV("ITEM #")=10 D ^ASUAUVAL
 ..S ASUREPLY("CORRECT")="N" Q
 I ASUREPLY("CORRECT")="Y" D ^ASUADUPD
 K X,Y,ASUREPLY("CORRECT")
 Q

ASUADNTR
ASUADNTR ;DSD/DFM - DUE IN ENTRY;  [ 04/15/98  2:32 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
 W !,"1. ENTER TRANSACTION CODE: ",ASUTRNS("TRANSACTION CODE")
 D ^ASUAUAST Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 D REQD^ASUAUPON Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 I $E(ASUTRNS("TRANSACTION CODE"),2,2)'?1N S ASUV("ITEM #")=5 D ^ASUAUIDX Q
 D ^ASUADTDU Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=6 D ^ASUAUACC Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=7 D ^ASUAUSSA Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=8 D ^ASUAUIDX Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=9 D ^ASUAUQTY Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=10 D ^ASUAUVAL Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 Q

ASUAPCAN
ASUAPCAN ;DSD/DFM - DIRECT ISSUE COMMON ACCOUNTING NUMBER (CAN);  [ 04/15/98  2:33 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
RDCAN ;
 S ASUVX=ASUK("AREA","ACCPT")
 I $E(ASUVX)=5 D
 .I ASUVX=50!(ASUVX=51) S ASUVX=$E(ASUVX)
 S DIR("A")=ASUV("ITEM #")_". ENTER COMMON ACCOUNTING NUMBER : J"_ASUVX
 S X=$S(ASUVX=5:5,1:4)
 S DIR(0)="FA^"_X_":"_X_"^K:X'?"_X_"AN X"
 S DIR("?")="Enter "_X_" alpha-numeric characters" K X
 D ^DIR
 I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) G EXIT
 S ASUTRNS(ASUTRNS,"COMMON ACCOUNT #")="J"_ASUVX_X
EXIT ;RETURN TO CALLING ROUTINE
 K X,Y,DIR,ASUVX
 Q

ASUAPCOR
ASUAPCOR ;DSD/DFM - DIRECT ISSUE CORRETION;  [ 04/15/98  2:36 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
 F  Q:$G(ASUREPLY("CORRECT"))="Y"  Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  D
 .Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  Q:ASUREPLY("CORRECT")="Y"
 .S DIR(0)="SB^Y:YES;N:NO;3:STATION;4:PURCHASE ORDER;5:SOURCE;6:ACCOUNT;7:OBJECT;8:USER;9:SUB STATION;10:COMMON ACCOUNTING;11:SUB SUB ACTIVITY;12:NUMBER OF LINE ITEMS;13:VALUE;14:VOUCHER"
 .D CORRECT^ASUAUYRN Q:ASUREPLY("CORRECT")="Y"  D
 ..D:ASUREPLY("CORRECT")="N"
 ...S DIR(0)="NOA^3:14:0"
 ...D GETFIELD^ASUAUYRN
 ..Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  Q:ASUREPLY("CORRECT")="Y"
 ..I ASUREPLY("CORRECT")="3" D  Q
 ...S DIR("B")=ASUTRNS(ASUTRNS,"STATION"),ASUTRNS(ASUTRNS,"STATION")=""
 ...D STAT^ASUAUAST
 ..I ASUREPLY("CORRECT")="4" D RDPON^ASUAUPON Q
 ..I ASUREPLY("CORRECT")="5" S ASUV("ITEM #")=5 D ^ASUAUSRC Q
 ..I ASUREPLY("CORRECT")<12 D
 ...S ASUV("ITEM #")=6 D ^ASUAUACC Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 ...S ASUV("ITEM #")=7 D ^ASUAUDOJ Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 ...S ASUV("ITEM #")=8 D ^ASUAPSST Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 ...S ASUV("ITEM #")=9 D ^ASUAUUSR Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 ...S ASUV("ITEM #")=10 D ^ASUAPCAN Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 ...S ASUV("ITEM #")=11 D ^ASUAUSSA
 ..I ASUREPLY("CORRECT")="12" D ^ASUAPNLI
 ..I ASUREPLY("CORRECT")="13" S ASUV("ITEM #")=12,ASUV("LOWEST")=1 D ^ASUAUVAL
 ..I ASUREPLY("CORRECT")="14" S ASUV("ITEM #")=13 D ^ASUAUVOU
 ..S ASUREPLY("CORRECT")="N" Q
 I ASUREPLY("CORRECT")="Y" D ^ASUAPUPD
 K X,Y,ASUREPLY("CORRECT")
 Q

ASUAPDUP
ASUAPDUP ;DSD/DFM - DIRECT ISSUE DUPLICATION;  [ 04/15/98  2:37 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
DUPFLDS ;
 K DIR("B")
 W !,"1. ENTER TRANSACTION CODE: ",ASUTRNS("TRANSACTION CODE")
 D AREA^ASUAUAST
 W !,"3. ENTER STATION CODE: ",ASUTRNS(ASUTRNS,"STATION")
 W !,"4. ENTER PURCHASE ORDER NUMBER: ",ASUTRNS(ASUTRNS,"PURCHASE ORDER #")
 G:ASUTRNS("TRANSACTION CODE")="02" OPTSRC
 G:$E(ASUTRNS("TRANSACTION CODE"),2,2)?1A OPTSRC
 W !,"5. ENTER SOURCE CODE: ",ASUTRNS(ASUTRNS,"SOURCE CODE") G ACCT
OPTSRC ;
 S:ASUTRNS(ASUTRNS,"SOURCE CODE")]"" DIR("B")=ASUTRNS(ASUTRNS,"SOURCE CODE")
 S ASUV("ITEM #")=5 D ^ASUAUSRC Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
ACCT ;
 S:ASUTRNS(ASUTRNS,"ACCOUNT")]"" DIR("B")=ASUTRNS(ASUTRNS,"ACCOUNT")
 S ASUV("ITEM #")=6 D ^ASUAUACC Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S:ASUTRNS(ASUTRNS,"SUB OBJECT")]"" DIR("B")=ASUTRNS(ASUTRNS,"SUB OBJECT")
 S ASUV("ITEM #")=7 D ^ASUAUDOJ Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUSW("OPTIONAL")="PO"
 S ASUV("ITEM #")=8 D ^ASUAPSST Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 K ASUSW("OPTIONAL")
 S:ASUTRNS(ASUTRNS,"USER")]"" DIR("B")=ASUTRNS(ASUTRNS,"USER")
 S ASUV("ITEM #")=9 D ^ASUAUUSR Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=10 D ^ASUAPCAN Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=11 D ^ASUAUSSA Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 D ^ASUAPNLI Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=13,ASUV("LOWEST")=1 D ^ASUAUVAL
 W !,"14. ENTER VOUCHER NUMBER: ",ASUTRNS(ASUTRNS,"VOUCHER #")
EXIT ;RETURN TO CALLING ROUTINE
 K X,Y,ASUV("ITEM #")
 Q

ASUAPNTR
ASUAPNTR ;DSD/DFM - DIRECT ISSUE ENTRY ;  [ 04/15/98  2:38 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
 W !,"1. ENTER TRANSACTION CODE: ",ASUTRNS("TRANSACTION CODE")
 D ^ASUAUAST Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 D REQD^ASUAUPON Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=5 D ^ASUAUSRC Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=6 D ^ASUAUACC Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=7 D ^ASUAUDOJ Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=8 D ^ASUAPSST Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 K ASUSW("OPTIONAL")
 S ASUV("ITEM #")=9 D ^ASUAUUSR Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=10 D ^ASUAPCAN Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=11 D ^ASUAUSSA Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 D ^ASUAPNLI Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUV("ITEM #")=13,ASUV("LOWEST")=1 D ^ASUAUVAL
 S ASUV("ITEM #")=14 D ^ASUAUVOU
EXIT ;RETURN TO CALLING ROUTINE
 K X,Y
 Q

ASUAPSST
ASUAPSST ;DSD/DFM - GET SUB STATION CODE FOR DICECT ISSUE;  [ 04/15/98  2:39 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
 K ASUTRSST
 S:'$D(ASUSW("OPTIONAL")) ASUSW("OPTIONAL")="P"
 K DIC
 S ASUK("ARST")=ASUK("AREA","ACCPT")_$S(ASUK("WAREHOUSE"):ASUK("STATION","MAIN"),1:ASUTRNS(ASUTRNS,"STATION"))
 S X=ASUTRNS(ASUTRNS,"STATION")
 S DIC("S")="I $P(^(0),U,3)=ASUK(""ARST"")"
 S DIC="9002039.2"
 S DIC(0)="MX"
 W !,ASUV("ITEM #")_". SUB STATION CODE: "_X
 D ^DIC
 I $D(DTOUT)!($D(DUOUT))!($D(DICOUT)) G EXIT
 I Y>0 S ASUTRSST=+Y,ASUTRNS(ASUTRNS,"SUB STATION")=$P(Y,U,2)
EXIT ;RETURN TO CALLING ROUTINE
 K X,Y,DIC,ASUSW("OPTIONAL")
 Q

ASUARDTX
ASUARDTX ;DSD/DFM - RECEIPT ENTER DATE OF EXPIRATION;  [ 04/15/98  2:44 PM ]
 ;;3.0;SAMS;**2**;AUG 20, 1993
RDDT4 ;
 S DIR("A")="13. ENTER EXPIRATION DATE"
 S DIR("?")="Enter a Date in 'MMYY' format not before current month - may be blank"
 S DIR(0)="FO^1:4^D DTCK^ASUARDTX"
 D ^DIR I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) G EXIT
 S ASUTRNS(ASUTRNS,"EXPIRATION DATE")=Y
EXIT ;RETURN TO CALLING ROUTINE
 K DIR,X,Y
 Q
DTCK ;
 I X="T"!(X="N") S Y=$E(ASUK("DATE","FM"),4,5)_$E(ASUK("DATE","FM"),2,3) W " ",Y Q
 I X["/" S %DT="F" D ^%DT I Y>0 S Y=$E(Y,4,5)_$E(Y,2,3) W " ",Y Q
 I $L(X)<4 W !,"Answer must be in MMYY format" K X Q
 I ($E(X,3,4)<$E(ASUK("DATE","FM"),2,3))&($E(X,3,4)>"85") W !,"Answer may not be for a previous year" K X Q   ;DFM 3/27/98 FIX UNTIL 2085
 I ($E(X,3,4)=$E(ASUK("DATE","FM"),2,3))&($E(X,1,2)<$E(ASUK("DATE","FM"),4,5)) W !,"Month must be current month or greater" K X Q
 I $E(X,1,2)>12!(+$E(X,1,2)<1) W !,"Month must be 01 - 12" K X Q
 S Y=X
 Q

ASUASEOQ
ASUASEOQ ;DSD/DFM - STATION TRANS ENTER EOQ TYPE CODE;  [ 04/15/98  2:46 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
RDEQTC ;
 S DIR("A")="9. ENTER EOQ TYPE CODE"
 S X="P" S:ASUTRNS("TRANSACTION CODE")="5C" X="PO"
 S DIR(0)=X_"^9002039.06:MXE" K X
 S DIR("?")="Enter valid Economic Type Code "
 D ^DIR
 I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) G EXIT
 S ASUTRNS(ASUTRNS,"EOQ TYPE")=$P(Y,U,2)
 S (ASUTRNS(ASUTRNS,"EOQ MOD MTHS"),ASUTRNS(ASUTRNS,"EOQ MOD QTY"),ASUTRNS(ASUTRNS,"EOQ ACT MO"))=""
 I ASUTRNS(ASUTRNS,"EOQ TYPE")']"",ASUTRNS(ASUTRNS,"REVIEW POINT QTY")']"",ASUTRNS("TRANSACTION CODE")="5C" G EXIT
 I ASUTRNS(ASUTRNS,"REVIEW POINT QTY")]""&(+ASUTRNS(ASUTRNS,"REVIEW POINT QTY")=0) G CKEQTC
 I ASUTRNS(ASUTRNS,"EOQ TYPE")="C" G RDEOQMM
 I ASUTRNS(ASUTRNS,"EOQ TYPE")="B" G RDEOQMQ
 I ASUTRNS(ASUTRNS,"EOQ TYPE")="Y"!(ASUTRNS(ASUTRNS,"EOQ TYPE")="D")!(ASUTRNS(ASUTRNS,"EOQ TYPE")="Q") G RDEOQAM
 G SETSW
CKEQTC ;
 I ASUTRNS(ASUTRNS,"EOQ TYPE")="P" G SETSW
 I ASUTRNS(ASUTRNS,"EOQ TYPE")="Y" G RDEOQAM
 W *7,!,"Review Point Quantity = 0, EOQ Type Code must be 'P' or 'Y'"
 G RDEQTC
RDEOQMM ;
 S DIR("A")="10. ENTER EOQ MODIFIER MONTHS"
 S DIR(0)="N^1:12:0" D ^DIR
 I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) G EXIT
 I $L(X)=1 S X="0"_X
 S ASUTRNS(ASUTRNS,"EOQ MOD MTHS")=X
 G SETSW
RDEOQMQ ;
 S DIR("A")="11. ENTER EOQ MODIFIER QUANTITY"
 S DIR(0)="N^1:9999:0" D ^DIR
 I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) G EXIT
 S Z="0000",X=$E(Z,1,4-$L(X))_X K Z
 S ASUTRNS(ASUTRNS,"EOQ MOD QTY")=X
 G SETSW
RDEOQAM ;READ EOQ ACTION MONTHS
 D ^ASUASQAM
 I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) G EXIT
SETSW ;
 I ASUTRNS("TRANSACTION CODE")="5C" S:ASUTRNS(ASUTRNS,"EOQ TYPE")]"" ASUSW("CHANGED")=1
EXIT ;RETURN TO CALLING ROUTINE
 K DIR,X,Y,Z
 Q

ASUAUARE
ASUAUARE ;DSD/DFM - UTILITY GET AREA CODE;  [ 04/15/98  2:48 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
 Q:$D(ASUK("AREA","ACCPT"))
 D CLS^ASUAULGO W *7 D:'$D(ASUK("AUTTAREA")) SETAREA I $D(ASUK("AREA","ACCPT")) I ASUK("AREA","ACCPT")=U Q
 W !?14,"REMINDER, AREA CODE YOU ARE SIGNED ON AS IS : ",ASUK("AUTTAREA"),!
 W !!?35-($L(ASUK("AREA NAME"))/2),ASUK("AREA NAME"),!!
 W !?10,"IF THIS IS CORRECT, ENTER <cr> AND CONTINUE DATA ENTRY"
 W !?10,"OTHERWISE, ENTER '^', EXIT FROM THE KERNEL STORES MENU"
 W !?15,"AND THEN REENTER WITH THE CORRECT AREA CODE",!!
 S DIR(0)="E" D ^DIR K DIR
 I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) S ASUK("AUTTAREA")=U
 S ASUK("AREA","ACCPT")=ASUK("AUTTAREA")
 K ASUK("AUTTAREA")
 Q
SETAREA ;EP ;SET ASUK("AUTTAREA") BASED ON DUZ(2)
 D LOOKUP
 S ASUF("LOOKA")=0
 D AREA^ASUAUTIL
 K ASUF("LOOKA")
 Q
LOOKUP ;EP ;CALL FROM ASUAUTIL
 D:'$D(U) ^XBKVAR
 I '$D(DUZ(2)) S ASUK("AREA","ACCPT")=U Q
 S ASUK("AUTTAREA")=$E($P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U,4),2,3),ASUK("AREA NAME")=$P($P(^(0),U)," ",1)
 S ASUK("WAREHOUSE")=$S(ASUK("AUTTAREA")=45:0,ASUK("AUTTAREA")=53:0,ASUK("AUTTAREA")=47:0,ASUK("AUTTAREA")=51:0,ASUK("AUTTAREA")=40:0,ASUK("AUTTAREA")=41:0,1:1)
 S:ASUK("AUTTAREA")=28 ASUK("WAREHOUSE")=2,ASUK("STATION","MAIN")=28 ;SIPAN
 S:ASUK("AUTTAREA")=67 ASUK("WAREHOUSE")=2,ASUK("STATION","MAIN")=18 ;HWLHDC
 S ASUK("LOCATION")=$P(^AUTTLOC(DUZ(2),0),U,2)
 S ASUK("AREA","ACCPT")=ASUK("AUTTAREA"),ASUK("ASUFAC")=$P(^AUTTLOC(DUZ(2),0),U,10)
 I ASUK("WAREHOUSE")=1 D  ;IHS WAREHOUSE AREAS
 .I ASUK("AREA","ACCPT")=42 S ASUK("STATION","MAIN")="01" Q  ;TUCSON
 .I ASUK("AREA","ACCPT")=50 S ASUK("STATION","MAIN")="05" Q  ;OKLAHOMA
 .I ASUK("AREA","ACCPT")=51 S ASUK("STATION","MAIN")="02" Q  ;NASHVILLE
 .I ASUK("AREA","ACCPT")=54 S ASUK("STATION","MAIN")=45 Q  ;NAVAJO
 .I ASUK("AREA","ACCPT")=59 S ASUK("STATION","MAIN")=37 Q  ;ALASKA
 .I ASUK("AREA","ACCPT")=64 S ASUK("STATION","MAIN")=49 ;PORTLAND
 S ASUK("STATION","MAIN")=$G(ASUK("STATION","MAIN"))
 I ASUK("AUTTAREA")']"" W "No Accounting Point stored in your SITE file; contact site manager",!,"Program can not continue - Aborting",! S ASUK("AREA","ACCPT")="^" Q
 Q

ASUAUAST
ASUAUAST ;DSD/DFM - UTILITY GET AREA & STATION ;  [ 04/15/98  2:50 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
 D AREA,STAT K DIR,DIC,X,Y Q
AREA ;EP ;AREA CODE
 K DIC S DIC=9002039.01,DIC(0)="MZE"
 W !,"2. ENTER AREA CODE: ",ASUK("AREA","ACCPT")
 S X=ASUK("AREA","ACCPT") D ^DIC I Y>0 S ASUTR(1,"AREA")=+Y
 Q
STAT ;EP ;STATION CODE CHECK
 I $E(ASUTRNS("TRANSACTION CODE"))=0 K DIC("S") G READDST
 I $D(ASUTRNS(ASUTRNS,"STATION")) I $L(ASUTRNS(ASUTRNS,"STATION"))>0 G STAFOUND
 S ASUTR(1,"STATION")=$O(^ASUTB01(ASUTR(1,"AREA"),1,"T","S","")) G:ASUTR(1,"STATION")="" STEXIT
 S ASUTRSTN=$O(^ASUTB01(ASUTR(1,"AREA"),1,"T","S",ASUTR(1,"STATION"))) I ASUTRSTN]"" K ASUTRSTN G READSTA
 K ASUTRSTN
 S ASUTRNS(ASUTRNS,"STATION")=$P(^ASUTB01(ASUTR(1,"AREA"),1,ASUTR(1,"STATION"),0),U)
 S ASUK("STATION","NAME")=$P(^ASUTB01(ASUTR(1,"AREA"),1,ASUTR(1,"STATION"),0),U,2)
STAFOUND ;
 W !,"3. ENTER STATION CODE ",ASUTRNS(ASUTRNS,"STATION")
 I '$D(ASUK("STATION","NAME")) G SETSTNM
 W ?30,ASUK("STATION","NAME") G STEXIT
READSTA ;STATION READ
 S DIC("S")="I $P(^ASUTB01(DA(1),1,+Y,0),U,3)=""S"""
READDST ;
 K ASUTRSST
 S DIR("A")="3. ENTER STATION CODE"
 S DIR("?")="Invalid Station Code for your Area"
 S DIR(0)="PE^ASUTB01("_ASUTR(1,"AREA")_",1,:MXE",DA(1)=ASUTR(1,"AREA")
 D ^ASUAUDIR
 I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) Q
 I Y>0 S ASUTR(1,"STATION")=+Y,ASUTRNS(ASUTRNS,"STATION")=$P(Y,U,2)
SETSTNM ;
 S ASUK("STATION","NAME")=$P(^ASUTB01(ASUTR(1,"AREA"),1,ASUTR(1,"STATION"),0),U,2)
 W ?30,ASUK("STATION","NAME")
STEXIT ;
 Q

ASUAUDIR
ASUAUDIR ;DSD/DFM - STANDARD POINTER TYPE READ ROUTINE WITH SCREENING;  [ 04/15/98  2:50 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
 ;THIS ROUTINE IS NEEDED TO DO SCREENING ON POINTER TYPE CALLS WHICH
 ;WOULD NORMALLY CALL DIR - WHEN DIR IS FIXED TO HANDLE SCREENING,
 ;THIS ROUTINE CAN BE DELETED AND ALL CALLS TO IT BE REPLACED WITH
 ;CALLS TO DIR
DIR ;
 S:$D(DIR("S")) DIC("S")=DIR("S")
 W !,DIR("A"),": "
 W:$D(DIR("B")) DIR("B"),"// "
 R X:DTIME
 I '$T S DTOUT=1 G EXIT
 S DIC=$P($P(DIR(0),U,2),":",1)
 I X="?",DIC=9002039.07,$D(ASUTRNS(ASUTRNS,"SUB OBJECT")),$D(ASUTR(0,"ACCOUNT")) D HELP7 G DIR
 I X="!" S X="" G DIR
 I X="",$D(DIR("B")) S X=DIR("B") K DIR("B") G READ
 I X="@" S X=""
 I X="",$P(DIR(0),U)["O" S Y=X G EXIT E  W !!,"This is a required entry.  Enter '^' to exit or '?' to see valid codes.",!! G DIR
 I X="^" K X S DUOUT=1 G EXIT
 I X="^^" K X S DIROUT=1 G EXIT
 I X'=" " G READ
 I '$D(DUZ) G NOSAVE
 I $E(DIC)?1"^" S ASUDIC=DIC G CKDISV
 I $E(DIC)?1A S ASUDIC=U_DIC G CKDISV
 I $E(DIC)?1N S ASUDIC=^DIC(DIC,0,"GL")
 I '$D(ASUDIC) G NOSAVE
 I ASUDIC']"" G NOSAVE
CKDISV ;
 I '$D(^DISV(DUZ,ASUDIC)) G NOSAVE
 G READ
NOSAVE ;
 W !,"Previous entry not available" G DIR
READ ;
 S:DIC'?1N.E DIC=U_DIC
 S DIC(0)=$P($P(DIR(0),U,2),":",2)
 D ^DIC I X="?" G DIR
 I Y<0 W *7,!!,DIR("?"),!,"Enter '^' to exit or '?' to see valid codes",!! G DIR
 I X=" " W $P(Y,U,2)
EXIT ;RETURN TO CALLING ROUTINE
 K ASUDIC,DIC
 Q
HELP7 ;
 S ASUTR(7,"CAT")=""
 F  S ASUTR(7,"CAT")=$O(^ASUTB07("D",ASUTRNS(ASUTRNS,"SUB OBJECT"),ASUTR(7,"CAT"))) Q:ASUTR(7,"CAT")=""  D
 .S ASUTR(7,"SOBJ")=$O(^ASUTB07("D",ASUTRNS(ASUTRNS,"SUB OBJECT"),ASUTR(7,"CAT"),""))
 .Q:$P(^ASUTB07(ASUTR(7,"CAT"),1,ASUTR(7,"SOBJ"),0),U)'=ASUTR(0,"ACCOUNT")
 .W !?5,^ASUTB07(ASUTR(7,"CAT"),0),?10,$P(^ASUTB07(ASUTR(7,"CAT"),1,ASUTR(7,"SOBJ"),0),U,3)
 K ASUTR(7,"CAT"),ASUTR(7,"SOBJ")
 Q

ASUAUIDX
ASUAUIDX ;DSD/DFM - UTILITY ENTER INDEX NUMBER;  [ 04/15/98  2:52 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
RDINDEX ;
 I ASUK("WAREHOUSE") D
 .S ASUSW("OPTIONAL")="NA"
 E  D
 .S ASUSW("OPTIONAL")="NOA"
 S DIR("A")=ASUV("ITEM #")_". ENTER INDEX NUMBER "
 S DIR(0)=ASUSW("OPTIONAL")_"^19:999997:0^D ^ASUAUM11"
 S DIR("?")="Index number must pass modulus 11 test"
 D ^DIR K DIR,ASUSW("OPTIONAL")
 I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) K X,Y Q
 I X="" S DTOUT=1 K X,Y Q
 S ASUTRNS(ASUTRNS,"INDEX")=Y K Y1,X,Y
 Q

ASUAUPON
ASUAUPON ;DSD/DFM - UTILITY ENTER PURCHASE ORDER NUMBER;  [ 04/15/98  2:54 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
RDPORD ;
 S DIR("A")="4. ENTER PURCHASE ORDER NUMBER"
 S DIR("?")="Enter 1 to 7 Characters - not all 0"
 S:'$D(ASUSW("OPTIONAL")) ASUSW("OPTIONAL")="F"
 S DIR(0)=ASUSW("OPTIONAL")_"^1:7^D POEDIT^ASUAUPON" D ^DIR
 I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) G EXIT
 S ASUTRNS(ASUTRNS,"PURCHASE ORDER #")=X
 S:ASUTRNS("TRANSACTION CODE")="5C" ASUSW("CHANGED")=1
EXIT ;RETURN TO CALLING ROUTINE
 K DIR,X,Y,ASUSW("OPTIONAL")
 Q
POEDIT ;EP ;EDIT PURCHASE ORDER NUMBER
 I $E(X)=0,+X=0 K X Q
 K:X'?.UNP X
 Q
RDPON ;EP ;READ PURCHASE ORDER NUMBER OPTIONAL
 I ASUTRNS("TRANSACTION CODE")="22"!(ASUTRNS("TRANSACTION CODE")="02") G RDPORD
 S ASUSW("OPTIONAL")="FO"
 G RDPORD
REQD ;EP ; READ PURCHASE ORDER NUMBER REQUIRED
 S ASUSW("OPTIONAL")="F"
 G RDPORD

ASUAUTIL
ASUAUTIL ;DSD/DFM -UTILITY SUB-ROUTINES;  [ 04/15/98  2:55 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
ARPRINT ;EP; Write out Area Name and save Area Lookup table EIN
 D ARL W " ",ASUK("AREA NAME") Q
AREA ;EP - Lookup Area Name. X=AREA CODE
 S ASUF("LOOKA")=$G(ASUF("LOOKA"))
 S:ASUF("LOOKA")="" ASUF("LOOKA")=1
 I $D(ASUK("AREA","ACCPT")) G ARL
 I ASUF("LOOKA"),'$D(X) D SETAREA^ASUAUARE S ASUF("LOOKA")=0 G ARX
 S ASUK("AREA","ACCPT")=X
ARL ;
 S ASUK("TR1","AREA")=$O(^ASUTB01("B",ASUK("AREA","ACCPT"),0))
 S ASUK("AREA NAME")=$S(ASUK("TR1","AREA")]"":$P(^ASUTB01(ASUK("TR1","AREA"),0),U,2),1:"")
 S ASUF("LOOKA")=$G(ASUF("LOOKA"))
 D:ASUF("LOOKA") LOOKUP^ASUAUARE
ARX ;
 Q
STPRINT ;
 D STL W " ",ASUK("STATION","NAME") Q
STAT ;EP - Lookup Station Name. X=AREA CODE, X1=STATION CODE.
 I $D(ASUK("AREA","ACCPT")) G STK
 I '$D(X) D  G STK
 .S X=$G(ASUK("AREA","ACCPT")) D:X="" SETAREA^ASUAUARE
 S ASUK("AREA","ACCPT")=X D ARL
STK ;
 I $D(ASUK("STATION","CODE")) G STL
 I '$D(X1) S (ASUK("STATION","CODE"),ASUK("STATION","NAME"))="" G STX
 S ASUK("STATION","CODE")=X1
STL ;
 S ASUK("TR1","STATION")=$O(^ASUTB01(ASUK("TR1","AREA"),1,"B",ASUK("STATION","CODE"),0))
 S ASUK("STATION","NAME")=$S(ASUK("TR1","STATION")]"":$P(^ASUTB01(ASUK("TR1","AREA"),1,ASUK("TR1","STATION"),0),U,2),1:"")
STX ;      
 Q
GL ;EP - Lookup GL Account Name. X=GL CODE
 S ASUK("ACCOUNT NAME")=$S($O(^ASUTBLA("B",X,0)):$P(^ASUTBLA($O(^ASUTBLA("B",X,0)),0),U,3),1:"")
 Q
ITEM ;EP - Lookup item Description 1 & 2. X=INDEX NUMBER.
 S (ASUIXM("DESCRIPTION1"),ASUIXM("DESCRIPTION2"))=""
 Q:'X
 Q:$L($O(^ASUINDX("B",X,0)))=0
 S X=$O(^ASUINDX("B",X,0))
 S ASUIXM("DESCRIPTION1")=$P(^ASUINDX(X,0),U,2)
 S ASUIXM("DESCRIPTION2")=$P(^ASUINDX(X,0),U,3)
 Q
LOGV ;EP; SAVE OR PRINT INVENTORY LOG DATA
 S:'$D(ASUK("PRINT QUEUED")) ASUK("PRINT QUEUED")=0
 I ASUK("PRINT QUEUED") D
 .S ASUK("LOG VLIN")=$G(ASUK("LOG VLIN"))+1
 .S ^ASUX(0,"V",ASUK("LOG VLIN"))=ASUTRX
 E  D
 .D:'$D(IO(0)) HOME^%ZIS U IO(0)
 .X ASUTRX
 .S DIR(0)="E" D ^DIR K DIR
 Q
LOG ;EP; SAVE OR PRINT LOG DATA
 S ASUK("LOG LINE")=$G(ASUK("LOG LINE"))+1
 S ^ASUX(0,ASUK("LOG LINE"))=ASUTRX
 S:'$D(ASUK("PRINT QUEUED")) ASUK("PRINT QUEUED")=0
 I ASUK("PRINT QUEUED") Q
 D:'$D(IO(0)) HOME^%ZIS U IO(0)
 X ASUTRX
 Q
PVLOG ;EP - QUEUED JOB LISTING
 I '$D(^ASUX(0,"V")) Q
 D CLS^ASUAULGO
 W !!,"The following are SAMS Inventory System messages from Queued Jobs:",!!
 F  S ASUK("LOG VLIN")=$O(^ASUX(0,"V",$G(ASUK("LOG VLIN")))) Q:ASUK("LOG VLIN")']""  D
 .X ^ASUX(0,"V",ASUK("LOG VLIN"))
 .S DIR(0)="E" D ^DIR K DIR
 W !!,"ALL MESSAGES HAVE BEEN PRINTED",!!
 S DIR(0)="E" D ^DIR K DIR
 K ^ASUX(0,"V"),ASUK("LOG VLIN")
 Q
COMDN ;EP - SET SIGN NEGATIVE, INSERT DECIMALS AND COMMAS
 I X'["." D
 .I $L(X)=1 D
 ..S X=".0"_X
 .E  D
 ..I $L(X)=2 D
 ...S X="."_X
 ..E  D
 ...D INDC
 S X=X*-1
 D COM
 Q
COMD ;EP - INSERT DECIMAL & COMMAS
 I X'["." D
 .D INDC
 D COM
 Q
COMN ;EP - SET SIGN NEGATIVE INSERT COMMAS
 S X=X*-1 D COM Q
COM ;EP - INSERT COMMAS & RIGHT JUSTIFY (X2 = # DECIMAL, X3 = SIZE OF OUTPUT)
 S:'$D(X2) X2=2
 S:'$D(X3) X3=12
 S X=$FN(X,"T,",X2)
 S X=$J(X,X3)
 Q
INDC ;EP INSERT DECIMAL POINT (IF NO X2, DEFAULT IS 2 PLACES)
 S:'$D(X2) X2=2
 I $L(X)<X2 S X4=$E("00000",1,X2-$L(X)),X="."_X4_X Q
 S X=$E(X,1,$L(X)-X2)_"."_$E(X,$L(X)-(X2-1),$L(X))
 Q
RND2D ;EP TO ROUND TO TWO DECIMAL PLACES
 S Y=$FN(X,"T",2) Q
RND0D ;EP TO ROUND TO WHOLE NUMBER
 S Y=$FN(X,"T",0)
PHONE ;EP INPUT TRANSFORM FOR A PHONE NUMBER
 D
 .I $L(X)>8 D
 ..I X'?1"(".3N.1") ".3N.1"-".4N K X
 .E  D
 ..I X'?3N.1"-".4N K X
 Q

ASUAUTL1
ASUAUTL1 ;DSD/DFM - DATE UTILITY FUNCTIONS;  [ 04/15/98  2:56 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
DAYTIM ;EP; - SET DATE AND TIME
 D DATE
 D TIME
 I $D(ASUTRNS) S ASUTRNS(ASUTRNS,"DATE ENTERED")=ASUK("DATE","FM")_"."_ASUK("TIME","F")_"."_$J
 Q
DATE ;EP; - SET ASUK("DATE")
 N X
 I ($D(ASUK("DATE"))#10)=0 D
 .D NOW^%DTC S Y=% X ^DD("DD")
 .D SETDT
 Q
SETDT ;
 S DT=X,DN=X
 S ASUK("DATE","FM")=X,ASUK("DATE")=$P(Y,"@",1),ASUK("DATE","TIME")=Y
 S ASUK("DATE","ENXYR")=$E(X,1,3)+1_"1231"
 S ASUK("DATE","YEAR")=$P(ASUK("DATE"),",",2),ASUK("DATE","YMD")=$E(X,2,7)
 S ASUK("DATE","YR")=$E(X,2,3),ASUK("DATE","MO")=$E(X,4,5),ASUK("DATE","DA")=$E(X,6,7)
 S ASUK("DATE","CFYEDT")=$E(X,1,3)
 S ASUK("DATE","MONTH")=$P(ASUK("DATE")," ")
 S ASUK("DATE","YRMO")=$E(X,2,5)
 S ASUK("DATE","FYMO")=ASUK("DATE","YRMO")
 S ASUK("DATE","CFY")=ASUK("DATE","YR")
 I +ASUK("DATE","MO")>9 D
 .S ASUK("DATE","CFYEDT")=ASUK("DATE","CFYEDT")+1
 .S ASUK("DATE","CFY")=$E(ASUK("DATE","CFYEDT"),2,3)
 .S ASUK("DATE","FYMO")=ASUK("DATE","CFY")_ASUK("DATE","MO")
 S ASUK("DATE","PFYBDT")=ASUK("DATE","CFYEDT")-1
 S ASUK("DATE","PFY")=$E(ASUK("DATE","PFYBDT"),2,3)
 S ASUK("DATE","CFYEDT")=ASUK("DATE","CFYEDT")_"1231"
 S ASUK("DATE","PFYBDT")=ASUK("DATE","PFYBDT")_"0131"
 Q:'$D(%H)
 S ASUK("DATE","H")=$P(%H,",",1),ASUK("TIME","H")=$P(%H,",",2)
 S ASUK("TIME")=$P(Y,"@",2)
 Q
ASKDATE ;EP - ASK FOR A DATE AND SET ASUK("DATE") ARRAY
 S %DT="AS" D ^%DT S X=Y
 X ^DD("DD")
 D SETDT,TIME
 Q
TIME ;EP; - SET ASUK("TIME")
 N X
 S %H=$H D YX^%DTC
 S ASUK("TIME")=$P(Y,"@",2),ASUK("TIME","H")=$P(%H,",",2)
 S ASUK("TIME","F")=$P(ASUK("TIME"),":")_$P(ASUK("TIME"),":",2)_$P(ASUK("TIME"),":",3)
 I ($D(ASUK("DATE"))#10) D
 .S ASUK("DATE","TIME")=ASUK("DATE")_"@"_ASUK("TIME")
 E  D
 .S ASUK("DATE","TIME")=Y
 Q
GETRUN ;EP ; - GET RUN FISCAL YEAR AND MONTH
 I ($D(ASUK("DATE"))#10)'=1 D DATE
 S DIR(0)="D" D ^DIR K DIR
 Q:$D(DTOUT)  Q:$D(DUOUT)
 S ASUK("DATE","RUNMY")=$E(Y,4,5)_$E(Y,2,3)
 W !
 S ASUK("DATE","RUNMO")=$E(ASUK("DATE","RUNMY"),1,2)
 S ASUK("DATE","RUNYR")=$E(ASUK("DATE","RUNMY"),3,4)
 I $E(ASUK("DATE","RUNMO"),1)=0&($E(ASUK("DATE","RUNMO"),2,2))>0 D
 .S ASUK("DATE","RUNMO")=$E(ASUK("DATE","RUNMO"),2,2)
 Q
SETQTR ;PEP ;SET QUARTER - INPUT DT AND ASUK("DATE","RUNMO") OUTPUT ASUK("DATE","RUNQTR") IN YEARQT FORMAT
 I ($D(ASUK("DATE"))#10)'=1 D DATE
 I '$D(ASUK("DATE","RUNMO")) S DIR("A")="Enter Month & Fiscal Year for Quarterly Reports (MMFY)" D GETRUN
 Q:$D(DTOUT)  Q:$D(DUOUT)
 S ASUVYR=$S(ASUK("DATE","RUNYR")<60:20,1:19)_ASUK("DATE","RUNYR")
 S ASUK("DATE","RUNQTR")=ASUVYR_$S(ASUK("DATE","RUNMO")<4:"02",ASUK("DATE","RUNMO")<7:"03",ASUK("DATE","RUNMO")>9:"01",1:"04")
 K ASUVYR
 Q

ASUAUVOU
ASUAUVOU ;DSD/DFM - UTILITY ENTER VOUCHER NUMBER;  [ 04/15/98  2:57 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
RDVOU ;
 S DIR("A")=ASUV("ITEM #")_". ENTER VOUCHER NUMBER"
 S DIR(0)="F^8:8^D EDIT^ASUAUVOU"
 S DIR("?")="^D HELP^ASUAUVOU"
 D ^DIR
 Q:$D(DUOUT)!($D(DIROUT))!($D(DTOUT))
 S ASUTRNS(ASUTRNS,"VOUCHER #")=X
EXIT ;RETURN TO CALLING ROUTINE
 K DIR,X,Y
 Q
HELP ;EP ;EXECUTABLE HELP FOR VOUCHER NUMBER
 W !!,"Voucher Number must be 8 numeric digits, not all zeros in format FYMMSER#"
 W !!,"Fiscal Year (FY) must be current fiscal year or previous fiscal year,"
 W !,"Month (MM) must be 01 through 12,"
 W !,"and Serial number (SER#) must be 0001 through 9999."
 Q
EDIT ;EP ;VOUCHER EDIT SUB ROUTINE
 I '$D(ASUK("DATE","FM")) N DN D DAYTIM^ASUAUTL1 S ASUF("DATE")=1
 S Y("EY")=$E(X,1,2)
 S Y("EM")=$E(X,3,4)
 S Y("ES")=$E(X,5,8),Y("SB")=1
 S Y("M1")="Voucher year not equal to current"
 S Y("M2")=" "
 S Y("M3")="or previous FY"
 I ASUK("DATE","MO")="09" D
 .S Y("SB")=2,Y("M2")=", next "
 I Y("EM")<1!(Y("EM")>12) D
 .W *7,!,"Month must be 01-12" K X
 E  D
 .S Y("DIF")=ASUK("DATE","CFY")-Y("EY")
 .I Y("DIF")>Y("SB")!(Y("DIF")<0) D
 ..W *7,!,Y("M1"),Y("M2"),Y("M3") K X
 .E  D
 ..I Y("ES")'>0 D
 ...W *7,!,"Voucher Serial Number may not be all zeros" K X
 ..E  D
 ...I $L(Y("ES"))<4!($L(Y("ES"))>4) D
 ....W *7,!,"Voucher Number must be a total of 8 digits" K X
 K:$D(ASUF("DATE")) ASUK("DATE")
 K Y
 Q

ASUAWXT
ASUAWXT ;DSD/DFM - EXTRACT TRANS - CONVERT TO DDPS FORMAT ;  [ 04/15/98  3:00 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
BEGIN ;EP;FOR RE-EXTRACT//^ASUAWXTW
 D:'$D(U) ^XBKVAR
 I '$D(IO(0)) S IOP=$I D ^%ZIS
 S ASUW("RUN TYPE")=$G(ASUW("RUN TYPE"))
 S:ASUW("RUN TYPE")']"" ASUW("RUN TYPE")=0
 S ASUW("TYPE LAST RUN")=^ASUTLRUN(1,0)
 I $P(ASUW("TYPE LAST RUN"),U,2)=8 G REXT2^ASUAWXTW
 S ASUX("EXTRACT DATE")=DT
OPNHFS ;EP;FOR RE-EXTRACT//^ASUAWXTW
 S ASUW("SAVE MEDIUM")=$P(ASUW("TYPE LAST RUN"),U,9)
 S ASUK("WAREHOUSE")=$G(ASUK("WAREHOUSE"))
 I ASUK("WAREHOUSE")<2 D ^ASUAWBTS
 K ^ASUPDATA
 ;KILL OF UNSUBSCRIPTED GLOBAL - EXTRACT FOR AIB TO DATA CENTER - NEW EACH MONTH
 S ASULNPAD=""
 S (ASUC(0),ASUC("TOT REC COUNT"),ASUC("ACCUMULATE COUNT"),ASUC("TOT PROC"))=0
 F ASUG("FILE NUMBER")=1:1:7 D
 .S ASUC(0)=ASUC(0)+1
 .S ASUG("SAVE NODE")="^ASUTRSV("_ASUG("FILE NUMBER")_",ASUX(""RECORD #""),"
 .S ASUG("TRAN GLOBAL")=U_$P(^ASUXCTRL(ASUG("FILE NUMBER"),0),U,2)
 .S ASUG("TRAN CODE PIECE #")=$P(^ASUXCTRL(ASUG("FILE NUMBER"),0),U,4)
 .S ASUG("AREA CODE PIECE #")=$P(^ASUXCTRL(ASUG("FILE NUMBER"),0),U,7)
 .S ASUG("ZERO NODE")=ASUG("TRAN GLOBAL")_"(0)"
 .S DIE=$E($P(@ASUG("ZERO NODE"),U,2),1,10)
 .S ASUX("FILE NAME")=$P(@ASUG("ZERO NODE"),U)
 .I ASUK("WAREHOUSE")<2 S ASUTRX="W !,""Now Processing "_ASUX("FILE NAME")_" Records"",!" D LOG^ASUAUTIL
 .S ASUX("SORT XREF")=$S($P(ASUW("TYPE LAST RUN"),U,2)=8:"AX",1:"C")
 .I ASUX("SORT XREF")="AX" D
 ..S (ASUX("STATUS"),ASUX("READ STATUS"))=ASUX("EXTRACT DATE")
 ..S ASUX("READ STATUS")=ASUX("READ STATUS")-1
 .E  D
 ..S ASUX("READ STATUS")=$S($P(ASUW("TYPE LAST RUN"),U,2)=9:"X",1:"T")
 ..S ASUX("STATUS")=$S(ASUX("READ STATUS")="X":"Y",1:"U")
 .S ASUX("RECORD #")=""
 .S ASUG("FIND STATUS")=ASUG("TRAN GLOBAL")_"(ASUX(""SORT XREF""),ASUX(""READ STATUS""))"
 .S ASUG("FIND RECORD")=ASUG("TRAN GLOBAL")_"(ASUX(""SORT XREF""),ASUX(""READ STATUS""),ASUX(""RECORD #""))"
 .F  S ASUX("READ STATUS")=$O(@ASUG("FIND STATUS")) Q:ASUX("READ STATUS")'=ASUX("STATUS")  D
 ..F  S ASUX("RECORD #")=$O(@ASUG("FIND RECORD")) Q:ASUX("RECORD #")=""  D
 ...S DA=ASUX("RECORD #"),ASUX("EXTR FLAG")=1
 ...I ASUK("WAREHOUSE")<2 D ^ASUAWXT1
 ...Q:ASUX("SORT XREF")="AX"
 ...S ASUC("TOT PROC")=ASUC("TOT PROC")+1
 ...I ASUX("EXTR FLAG") S DR=".09///"_ASUX("EXTRACT DATE")_";.08///X" D ^DIE
 .S ASUC(ASUG("FILE NUMBER"))=ASUC("TOT REC COUNT")-ASUC("ACCUMULATE COUNT")
 .S $P(^ASUXCTRL(ASUG("FILE NUMBER"),0),U,5)=ASUC(ASUG("FILE NUMBER"))
 .S $P(^ASUXCTRL(ASUG("FILE NUMBER"),0),U,6)=ASUX("EXTRACT DATE")
 .S ASUC("ACCUMULATE COUNT")=ASUC("TOT REC COUNT")
 .I ASUK("WAREHOUSE")<2 S ASUTRX="W !,"""_ASUX("FILE NAME")_" Record Count : "","_$P(^ASUXCTRL(ASUG("FILE NUMBER"),0),U,5) D LOG^ASUAUTIL
 S ASUTRX="W !,*7,""Conversion Completed"",*7" D LOG^ASUAUTIL
 S ASUTRX="W !,""Total records processed: "","_ASUC("TOT PROC") D LOG^ASUAUTIL
 I ASUC("TOT REC COUNT")=0 D
 .S ASUTRX="W !,""There were no current records converted"",*7,!"
 .D LOG^ASUAUTIL
 .I 1
 E  D
 .S ASUTRX="W !,""Total records converted "","_ASUC("TOT REC COUNT")
 .D SETAREA^ASUAUARE
 .S ^ASUPDATA(0)=ASUK("ASUFAC")_U_ASUK("AREA NAME")_U_ASUX("EXTRACT DATE")_U_ASUX("EXTRACT DATE")_U_ASUX("EXTRACT DATE")_U_U_ASUC("TOT REC COUNT")
 .I ASUK("WAREHOUSE") D
 ..I ASUW("RUN TYPE") S $P(^ASUTLRUN(1,0),U,8)=ASUX("EXTRACT DATE") D ^ASUAWXT2
 .E  D
 ..S $P(^ASUTLRUN(1,0),U,8)=ASUX("EXTRACT DATE") D ^ASUAWXT2
 .S AUMED=$S(ASUW("SAVE MEDIUM")]"":ASUW("SAVE MEDIUM"),1:"F") D SAVE
 I $G(ASUK("PRINT QUEUED"))'=1 S DIR(0)="E" D ^DIR
 K ASUX,ASU0,ASU1,ASU2,ASUC,ASUG,ASUT,ASUNPAD,ASULNPAD,ASUFTAPE,AUGL
 K DA,DR,DIE,DTOUT,DUOUT,DIROUT
 K:$G(ASUW("RUN TYPE"))="" ASUV,ASUW
 Q
SV1 ;EP ;
 S AUMED="F",AUUF="/usr/spool/uucppublic"
 S:'$D(ASUK("WAREHOUSE")) ASUK("WAREHOUSE")=1
SAVE ;EP; SAVE GLOBAL
 I ASUK("WAREHOUSE")=2 Q
 S AUGL="ASUPDATA" D ^AUGSAVE K AUGL
 I AUFLG D
 .S ASUTRX="W !!,""Save of ASUPDATA Unsucessful - """ D LOG^ASUAUTIL
 .F ASU("AUFLG")=1:1 Q:'$D(AUFLG(ASU("AUFLG")))  D
 ..S ASUTRX="W """_AUFLG(ASU("AUFLG"))_""",!" D LOG^ASUAUTIL
 K AUFLG
 Q
 S AUGL="ASUTRSV",AUMED="F" D ^AUGSAVE K AUGL
 I AUFLG D
 .S ASUTRX="W !!,""Save of ASUTRSV Unsucessful - """ D LOG^ASUAUTIL
 .F ASU("AUFLG")=1:1 Q:'$D(AUFLG(ASU("AUFLG")))  D
 ..S ASUTRX="W """_AUFLG(ASU("AUFLG"))_""",!" D LOG^ASUAUTIL
 K AUFLG
 Q

ASUAWXTW
ASUAWXTW ;DSD/DFM - EXTRACT TRANS - RE-EXTRACT AND DATA ENTRY ONLY OPTIONS;  [ 04/15/98  3:01 PM ]
 ;;3.0;SAMS;**1**;AUG 20, 1993
REXT ;PEP;RE-EXTRACT
 S DIR(0)="Y",DIR("A")="DO YOU WISH TO RE-EXTRACT TRANSACTIONS"
 S DIR("?",1)="Enter 'Y' to re-extract previously extracted, or"
 S DIR("?")=" 'N' to be prompted for a regular extract of updated transactions."
 D ^DIR K DIR
 Q:$D(DTOUT)  Q:$D(DUOUT)
 G:Y CONTURXT
 S DIR(0)="Y",DIR("A")="DO YOU WISH TO EXTRACT UPDATED TRANSACTIONS"
 S DIR("?",1)="Enter 'Y' to extract updated transactions, or"
 S DIR("?")=" 'N' to end this option selection."
 D ^DIR K DIR
 Q:$D(DTOUT)  Q:$D(DUOUT)
 G:Y BEGIN^ASUAWXT
 Q
CONTURXT ;
 S ASUW("TYPE LAST RUN")=^ASUTLRUN(1,0)
 S $P(ASUW("TYPE LAST RUN"),U,2)=8
 D:'$D(U) ^XBKVAR
 I '$D(IO(0)) S IOP=$I D ^%ZIS
 S ASUW("RUN TYPE")=$G(ASUW("RUN TYPE")) S:ASUW("RUN TYPE")']"" ASUW("RUN TYPE")=0
REXT2 ;EP ; RE-EXTRACT DATA
 S DIR(0)="D",DIR("A")="ENTER RE-EXTRACT DATE",DIR("?")="^D DATEHELP^ASUAWXTW" D ^DIR Q:$D(DTOUT)  Q:$D(DUOUT)!($D(DIROUT))
 S ASUX("EXTRACT DATE")=Y X ^DD("DD") W " ",Y
 K DIR,Y G OPNHFS^ASUAWXT
DATEHELP ;
 W !,"Enter the Extracted Date on records to be re-extracted.  Dates in Issues are:"
 S X=0 F  S X=$O(^ASU3("AX",X)) Q:X'?1N.N  W !,$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)
 Q
DAOL ;PEP; DATA ENTRY ONLY
 S ASUW("TYPE LAST RUN")=^ASUTLRUN(1,0)
 S $P(ASUW("TYPE LAST RUN"),U,2)=9,ASUX("EXTRACT DATE")=DT
 D:'$D(U) ^XBKVAR
 I '$D(IO(0)) S IOP=$I D ^%ZIS
 S ASUW("RUN TYPE")=$G(ASUW("RUN TYPE"))
 S:ASUW("RUN TYPE")']"" ASUW("RUN TYPE")=0
 D:'$D(ASUK("DATE","RUNMO")) GETRUN^ASUAUTL1
 G OPNHFS^ASUAWXT
END ;
 Q