ASUCOMOR ; IHS/ITSC/LMH -MONTH REPORT DRIVER ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine controls the sequence for processing during a monthly
;closeout update run.
D TIME^ASUUDATE
S:$G(ASUP("TYP"))']"" ASUP("TYP")=2
S ASUP("CKM")=+$G(ASUP("CKM"))
Q:ASUP("CKM")>20
S ASURX="W !,""S.A.M.S. Monthly Reports Procedure begun "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
G:ASUP("CKM")>1 SORT
XTR ;
I ASUP("CKM")=0 D
.I ASUP("UPLD")=1!(ASUP("UPLD")=3) D
..D TIME^ASUUDATE
..S ASURX="W !,""Month end Upload for SAMS Processing "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
..I ASUP("CKM")=0
..D MO^ASUW2SAM(ASUP("MO")) Q:ASUP("HLT") S ASUP("CKM")=1 D SETSM^ASUCOSTS
..D TIME^ASUUDATE
..S ASURX="W !,""Month end Upload for SAMS Completed "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
.I ASUP("UPLD")=2!(ASUP("UPLD")=3) D
..D TIME^ASUUDATE
..S ASURX="W !,""Month end Extract for STORES Processing "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
..I ASUP("CKM")=0
..D MO^ASUW2STO(ASUP("MO")) Q:ASUP("HLT") S ASUP("CKM")=1 D SETSM^ASUCOSTS
..D TIME^ASUUDATE
..S ASURX="W !,""Month end Extract for STORES Completed "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
SORT ;
I ASUP("CKM")=1 S ASUP("CKM")=2 D SETSM^ASUCOSTS
I ASUP("CKM")=2 D Q:ASUP("HLT")
.S ASURX="W !?3,""Monthly Extracts being built for reports: 10V""" D ^ASUUPLOG
.;D ^ASUMCPSM,TRANS^ASUMCPSM Q:ASUP("HLT")
.S ASUP("CKM")=3 D SETSM^ASUCOSTS
I ASUP("CKM")=3 D Q:ASUP("HLT")
.S ASURX="W "" 12""" D ^ASUUPLOG
.D SORT^ASURM12P Q:ASUP("HLT") S ASUP("CKM")=4 D SETSM^ASUCOSTS
I ASUP("CKM")=4 D Q:ASUP("HLT")
.S ASURX="W "" 14""" D ^ASUUPLOG
.;D SORT^ASURM14P Q:ASUP("HLT")
.S ASUP("CKM")=5 D SETSM^ASUCOSTS
I ASUP("CKM")=5 D Q:ASUP("HLT")
.S ASURX="W "" 15""" D ^ASUUPLOG
.;beginning Y2K
.;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
.D Y2K ;Y2000
.;end Y2K fix block
.D GET^ASURM15P Q:ASUP("HLT")
.S ASUP("CKM")=6 D SETSM^ASUCOSTS
I ASUP("CKM")=6 D Q:ASUP("HLT")
.S ASURX="W "" 16""" D ^ASUUPLOG
.;begin Y2K
.;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
.D Y2K ;Y2000
.;end Y2K fix block
.D GET^ASURM16P Q:ASUP("HLT")
.S ASUP("CKM")=7 D SETSM^ASUCOSTS
I ASUP("CKM")=7 D Q:ASUP("HLT")
.S ASURX="W "" 17""" D ^ASUUPLOG
.;begin Y2K
.;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
.D Y2K ;Y2000
.;end Y2K fix block
.D GET^ASURM17P Q:ASUP("HLT")
.S ASUP("CKM")=8 D SETSM^ASUCOSTS
I ASUP("CKM")=8 D Q:ASUP("HLT")
.S ASURX="W "" 23""" D ^ASUUPLOG
.D SORT^ASURM23P Q:ASUP("HLT") S ASUP("CKM")=9 D SETSM^ASUCOSTS
I ASUP("CKM")=9 D Q:ASUP("HLT")
.S ASURX="W "" 24""" D ^ASUUPLOG
.D SORT^ASURM24P Q:ASUP("HLT") S ASUP("CKM")=10 D SETSM^ASUCOSTS
I ASUP("CKM")=10 D Q:ASUP("HLT")
.S ASURX="W "" 74""" D ^ASUUPLOG
.D CMPT^ASURM74P Q:ASUP("HLT") S ASUP("CKM")=11 D SETSM^ASUCOSTS
I ASUP("CKM")=11 D Q:ASUP("HLT")
.S ASURX="W "" 76""" D ^ASUUPLOG
.D ^ASURO760 Q:ASUP("HLT") S ASUP("CKM")=12 D SETSM^ASUCOSTS
I ASUP("CKM")=12 D Q:ASUP("HLT")
.S ASURX="W "" 79""" D ^ASUUPLOG
.D CMPT^ASURM79P Q:ASUP("HLT") S ASUP("CKM")=13 D SETSM^ASUCOSTS
;WAR 4/15/99 TEMP FIX FOR NOW... NEED TO REMOVE LATER
S ASUP("CKM")=18 D SETSM^ASUCOSTS
G SKIP ; AGAIN, REMOVE THIS LATER
I ASUP("CKM")=13 D Q:ASUP("HLT")
.S ASURX="W "" DBA""" D ^ASUUPLOG
.;begin Y2K
.;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
.D Y2K ;Y2000
.;end Y2K fix block
.D GET^ASURMDBA Q:ASUP("HLT") S ASUP("CKM")=14 D SETSM^ASUCOSTS
I ASUP("CKM")=14 D Q:ASUP("HLT")
.S ASURX="W "" DBC""" D ^ASUUPLOG
.;begin Y2K
.;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
.D Y2K ;Y2000
.;end Y2K fix block
.D GET^ASURMDBC Q:ASUP("HLT") S ASUP("CKM")=15 D SETSM^ASUCOSTS
I ASUP("CKM")=15 D Q:ASUP("HLT")
.S ASURX="W "" DBH""" D ^ASUUPLOG
.;begin Y2K
.;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
.D Y2K ;Y2000
.;end Y2K fix block
.D GET^ASURMDBH Q:ASUP("HLT") S ASUP("CKM")=16 D SETSM^ASUCOSTS
I ASUP("CKM")=16 D Q:ASUP("HLT")
.S ASURX="W "" DBK""" D ^ASUUPLOG
.;begin Y2K
.;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
.D Y2K ;Y2000
.;end Y2K fix block
.N X F X=1:1:5,9,999 D
..S ASURPT="K"_X
..D GET^ASURMDBK Q:ASUP("HLT")
.S ASUP("CKM")=17 D SETSM^ASUCOSTS
I ASUP("CKM")=17 D Q:ASUP("HLT")
.S ASURX="W "" DBL""" D ^ASUUPLOG
.;begin Y2K
.;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
.D Y2K ;Y2000
.;end Y2K fix block
.D GET^ASURMDBL Q:ASUP("HLT") S ASUP("CKM")=18 D SETSM^ASUCOSTS
SKIP ;
I ASUP("CKM")=18 D Q:ASUP("HLT")
.S ASURX="W !?3,""Station Master PAMIQ and RPQ recalculating""" D ^ASUUPLOG
.D PAMIQ Q:ASUP("HLT") S ASUP("CKM")=19 D SETSM^ASUCOSTS
I ASUP("CKM")=19 D Q:ASUP("HLT")
.S ASURX="W !?3,""Clearing and Updating YTD ISSUE DATA fields""" D ^ASUUPLOG
.D MO^ASUMYDPS Q:ASUP("HLT") S ASUP("CKM")=20 D SETSM^ASUCOSTS
I ASUP("CKM")=20 D Q:ASUP("HLT")
.S ASURX="W !?3,""Clearing and Updating ISSUE BOOK fields""" D ^ASUUPLOG
.D CLMO^ASUMKBPS Q:ASUP("HLT") S ASUP("CKM")=21 D SETSM^ASUCOSTS
.I ASUP("OLIB") D CRMSTR^ASUJOLIB
D TIME^ASUUDATE
S ASURX="W !,""S.A.M.S. Monthly Closeout Procedure ended "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
Q
PAMIQ ;END OF MONTH RECALCULATE PAMIQ
;This sub routine is used to calculate a new Projected
;Average Issue Quantity (PAMIQ) for each Index number. The PAMIQ is
;used in calculating the Economic Order Quantity (EOQ) whenever stock
;for the Index item gets low enough appear on the Requirements
;Analysis Report (Report 13) entry.
S (ASUMS("RPQ"),ASUMS("E#","IDX"),ASUMS("PMIQ"))=""
S ASUMS("E#","STA")=0
F S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:ASUMS("E#","STA")'?1N.N S ASUMS("E#","IDX")=0 D
.F S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")'?1N.N D
..D ^ASUMSTRD
..Q:ASUF("DLIDX")
..S ASUMS("RPQ-O")=ASUMS("RPQ") ;Save Old Review Point Quantity
..S X=ASUMS("ESTB") S:+($E(X,6,7))=0 X=X+30 ;If day = 0 set to 30
..D H^%DTC S X(2)=%H
..S X=ASUK("DT","FM") D H^%DTC S X(3)=%H
..S X(2)=X(3)-X(2) K X(3) ;Get diff of today - date estb
..I X(2)<366 D ;Less than a year since established
...S ASUMS("PMIQ-F")=ASUMS("PMIQ")*.60 ;Old PAMIQ weight 60%
...S ASUV("CISSWT")=ASUMS("DMD","QTY",+ASUP("MO"))*.40 ;Current Month issues weight 40%
..I X(2)>365 D ;More than a year since established
...S ASUMS("PMIQ-F")=ASUMS("PMIQ")*.90 ;Old PAMIQ weight 90%
...S ASUV("CISSWT")=ASUMS("DMD","QTY",+ASUP("MO"))*.10 ;Current Month issues weight 10%
..K X
..S ASUMS("PMIQ")=$FN(ASUMS("PMIQ-F")+ASUV("CISSWT"),"-",0) ;Calculate new PAMIQ and round to even number
..S ASUV("MO")=ASUP("MO")+1 S:ASUV("MO")=13 ASUV("MO")=1
..S ASUMS("DMD","QTY",ASUV("MO"))="" ;Reset Demand Quantity for this month next year
..S ASUMS("DMD","CALL",ASUV("MO"))="" ;Reset Demand Calls for this month next year
..I ASUMS("EOQ","TP")'="P" D
...S ASUMS("RPQ")=$FN(((ASUMS("LTM")+ASUMS("SFSKM"))*ASUMS("PMIQ")),"-",0) ;Calculate new RPQ and round off to even quantity
..D ^ASUMSTWR ;Update Station master
Q
Y2K ;begin Y2K
S X=$E(ASUK("DT","FM"),2,5) ;Y2000 CYYMM
D START^ASUUY2K(.X,1,U,"Y") ;Y2000
S ASUDT=Y ;Y2000
S ASUTYP="M" ;Y2000
;end Y2K fix block
Q
ASUCOMOR ; IHS/ITSC/LMH -MONTH REPORT DRIVER ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine controls the sequence for processing during a monthly
+3 ;closeout update run.
+4 DO TIME^ASUUDATE
+5 IF $GET(ASUP("TYP"))']""
SET ASUP("TYP")=2
+6 SET ASUP("CKM")=+$GET(ASUP("CKM"))
+7 IF ASUP("CKM")>20
QUIT
+8 SET ASURX="W !,""S.A.M.S. Monthly Reports Procedure begun "_ASUK("DT","TIME")_""""
DO ^ASUUPLOG
+9 IF ASUP("CKM")>1
GOTO SORT
XTR ;
+1 IF ASUP("CKM")=0
Begin DoDot:1
+2 IF ASUP("UPLD")=1!(ASUP("UPLD")=3)
Begin DoDot:2
+3 DO TIME^ASUUDATE
+4 SET ASURX="W !,""Month end Upload for SAMS Processing "_ASUK("DT","TIME")_""""
DO ^ASUUPLOG
+5 IF ASUP("CKM")=0
+6 DO MO^ASUW2SAM(ASUP("MO"))
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=1
DO SETSM^ASUCOSTS
+7 DO TIME^ASUUDATE
+8 SET ASURX="W !,""Month end Upload for SAMS Completed "_ASUK("DT","TIME")_""""
DO ^ASUUPLOG
End DoDot:2
+9 IF ASUP("UPLD")=2!(ASUP("UPLD")=3)
Begin DoDot:2
+10 DO TIME^ASUUDATE
+11 SET ASURX="W !,""Month end Extract for STORES Processing "_ASUK("DT","TIME")_""""
DO ^ASUUPLOG
+12 IF ASUP("CKM")=0
+13 DO MO^ASUW2STO(ASUP("MO"))
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=1
DO SETSM^ASUCOSTS
+14 DO TIME^ASUUDATE
+15 SET ASURX="W !,""Month end Extract for STORES Completed "_ASUK("DT","TIME")_""""
DO ^ASUUPLOG
End DoDot:2
End DoDot:1
SORT ;
+1 IF ASUP("CKM")=1
SET ASUP("CKM")=2
DO SETSM^ASUCOSTS
+2 IF ASUP("CKM")=2
Begin DoDot:1
+3 SET ASURX="W !?3,""Monthly Extracts being built for reports: 10V"""
DO ^ASUUPLOG
+4 ;D ^ASUMCPSM,TRANS^ASUMCPSM Q:ASUP("HLT")
+5 SET ASUP("CKM")=3
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+6 IF ASUP("CKM")=3
Begin DoDot:1
+7 SET ASURX="W "" 12"""
DO ^ASUUPLOG
+8 DO SORT^ASURM12P
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=4
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+9 IF ASUP("CKM")=4
Begin DoDot:1
+10 SET ASURX="W "" 14"""
DO ^ASUUPLOG
+11 ;D SORT^ASURM14P Q:ASUP("HLT")
+12 SET ASUP("CKM")=5
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+13 IF ASUP("CKM")=5
Begin DoDot:1
+14 SET ASURX="W "" 15"""
DO ^ASUUPLOG
+15 ;beginning Y2K
+16 ;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
+17 ;Y2000
DO Y2K
+18 ;end Y2K fix block
+19 DO GET^ASURM15P
IF ASUP("HLT")
QUIT
+20 SET ASUP("CKM")=6
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+21 IF ASUP("CKM")=6
Begin DoDot:1
+22 SET ASURX="W "" 16"""
DO ^ASUUPLOG
+23 ;begin Y2K
+24 ;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
+25 ;Y2000
DO Y2K
+26 ;end Y2K fix block
+27 DO GET^ASURM16P
IF ASUP("HLT")
QUIT
+28 SET ASUP("CKM")=7
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+29 IF ASUP("CKM")=7
Begin DoDot:1
+30 SET ASURX="W "" 17"""
DO ^ASUUPLOG
+31 ;begin Y2K
+32 ;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
+33 ;Y2000
DO Y2K
+34 ;end Y2K fix block
+35 DO GET^ASURM17P
IF ASUP("HLT")
QUIT
+36 SET ASUP("CKM")=8
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+37 IF ASUP("CKM")=8
Begin DoDot:1
+38 SET ASURX="W "" 23"""
DO ^ASUUPLOG
+39 DO SORT^ASURM23P
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=9
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+40 IF ASUP("CKM")=9
Begin DoDot:1
+41 SET ASURX="W "" 24"""
DO ^ASUUPLOG
+42 DO SORT^ASURM24P
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=10
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+43 IF ASUP("CKM")=10
Begin DoDot:1
+44 SET ASURX="W "" 74"""
DO ^ASUUPLOG
+45 DO CMPT^ASURM74P
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=11
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+46 IF ASUP("CKM")=11
Begin DoDot:1
+47 SET ASURX="W "" 76"""
DO ^ASUUPLOG
+48 DO ^ASURO760
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=12
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+49 IF ASUP("CKM")=12
Begin DoDot:1
+50 SET ASURX="W "" 79"""
DO ^ASUUPLOG
+51 DO CMPT^ASURM79P
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=13
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+52 ;WAR 4/15/99 TEMP FIX FOR NOW... NEED TO REMOVE LATER
+53 SET ASUP("CKM")=18
DO SETSM^ASUCOSTS
+54 ; AGAIN, REMOVE THIS LATER
GOTO SKIP
+55 IF ASUP("CKM")=13
Begin DoDot:1
+56 SET ASURX="W "" DBA"""
DO ^ASUUPLOG
+57 ;begin Y2K
+58 ;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
+59 ;Y2000
DO Y2K
+60 ;end Y2K fix block
+61 DO GET^ASURMDBA
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=14
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+62 IF ASUP("CKM")=14
Begin DoDot:1
+63 SET ASURX="W "" DBC"""
DO ^ASUUPLOG
+64 ;begin Y2K
+65 ;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
+66 ;Y2000
DO Y2K
+67 ;end Y2K fix block
+68 DO GET^ASURMDBC
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=15
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+69 IF ASUP("CKM")=15
Begin DoDot:1
+70 SET ASURX="W "" DBH"""
DO ^ASUUPLOG
+71 ;begin Y2K
+72 ;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
+73 ;Y2000
DO Y2K
+74 ;end Y2K fix block
+75 DO GET^ASURMDBH
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=16
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+76 IF ASUP("CKM")=16
Begin DoDot:1
+77 SET ASURX="W "" DBK"""
DO ^ASUUPLOG
+78 ;begin Y2K
+79 ;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
+80 ;Y2000
DO Y2K
+81 ;end Y2K fix block
+82 NEW X
FOR X=1:1:5,9,999
Begin DoDot:2
+83 SET ASURPT="K"_X
+84 DO GET^ASURMDBK
IF ASUP("HLT")
QUIT
End DoDot:2
+85 SET ASUP("CKM")=17
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+86 IF ASUP("CKM")=17
Begin DoDot:1
+87 SET ASURX="W "" DBL"""
DO ^ASUUPLOG
+88 ;begin Y2K
+89 ;S ASUDT=$E(ASUK("DT","FM"),1,5)_"00",ASUTYP="M"
+90 ;Y2000
DO Y2K
+91 ;end Y2K fix block
+92 DO GET^ASURMDBL
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=18
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
SKIP ;
+1 IF ASUP("CKM")=18
Begin DoDot:1
+2 SET ASURX="W !?3,""Station Master PAMIQ and RPQ recalculating"""
DO ^ASUUPLOG
+3 DO PAMIQ
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=19
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+4 IF ASUP("CKM")=19
Begin DoDot:1
+5 SET ASURX="W !?3,""Clearing and Updating YTD ISSUE DATA fields"""
DO ^ASUUPLOG
+6 DO MO^ASUMYDPS
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=20
DO SETSM^ASUCOSTS
End DoDot:1
IF ASUP("HLT")
QUIT
+7 IF ASUP("CKM")=20
Begin DoDot:1
+8 SET ASURX="W !?3,""Clearing and Updating ISSUE BOOK fields"""
DO ^ASUUPLOG
+9 DO CLMO^ASUMKBPS
IF ASUP("HLT")
QUIT
SET ASUP("CKM")=21
DO SETSM^ASUCOSTS
+10 IF ASUP("OLIB")
DO CRMSTR^ASUJOLIB
End DoDot:1
IF ASUP("HLT")
QUIT
+11 DO TIME^ASUUDATE
+12 SET ASURX="W !,""S.A.M.S. Monthly Closeout Procedure ended "_ASUK("DT","TIME")_""""
DO ^ASUUPLOG
+13 QUIT
PAMIQ ;END OF MONTH RECALCULATE PAMIQ
+1 ;This sub routine is used to calculate a new Projected
+2 ;Average Issue Quantity (PAMIQ) for each Index number. The PAMIQ is
+3 ;used in calculating the Economic Order Quantity (EOQ) whenever stock
+4 ;for the Index item gets low enough appear on the Requirements
+5 ;Analysis Report (Report 13) entry.
+6 SET (ASUMS("RPQ"),ASUMS("E#","IDX"),ASUMS("PMIQ"))=""
+7 SET ASUMS("E#","STA")=0
+8 FOR
SET ASUMS("E#","STA")=$ORDER(^ASUMS(ASUMS("E#","STA")))
IF ASUMS("E#","STA")'?1N.N
QUIT
SET ASUMS("E#","IDX")=0
Begin DoDot:1
+9 FOR
SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX")))
IF ASUMS("E#","IDX")'?1N.N
QUIT
Begin DoDot:2
+10 DO ^ASUMSTRD
+11 IF ASUF("DLIDX")
QUIT
+12 ;Save Old Review Point Quantity
SET ASUMS("RPQ-O")=ASUMS("RPQ")
+13 ;If day = 0 set to 30
SET X=ASUMS("ESTB")
IF +($EXTRACT(X,6,7))=0
SET X=X+30
+14 DO H^%DTC
SET X(2)=%H
+15 SET X=ASUK("DT","FM")
DO H^%DTC
SET X(3)=%H
+16 ;Get diff of today - date estb
SET X(2)=X(3)-X(2)
KILL X(3)
+17 ;Less than a year since established
IF X(2)<366
Begin DoDot:3
+18 ;Old PAMIQ weight 60%
SET ASUMS("PMIQ-F")=ASUMS("PMIQ")*.60
+19 ;Current Month issues weight 40%
SET ASUV("CISSWT")=ASUMS("DMD","QTY",+ASUP("MO"))*.40
End DoDot:3
+20 ;More than a year since established
IF X(2)>365
Begin DoDot:3
+21 ;Old PAMIQ weight 90%
SET ASUMS("PMIQ-F")=ASUMS("PMIQ")*.90
+22 ;Current Month issues weight 10%
SET ASUV("CISSWT")=ASUMS("DMD","QTY",+ASUP("MO"))*.10
End DoDot:3
+23 KILL X
+24 ;Calculate new PAMIQ and round to even number
SET ASUMS("PMIQ")=$FNUMBER(ASUMS("PMIQ-F")+ASUV("CISSWT"),"-",0)
+25 SET ASUV("MO")=ASUP("MO")+1
IF ASUV("MO")=13
SET ASUV("MO")=1
+26 ;Reset Demand Quantity for this month next year
SET ASUMS("DMD","QTY",ASUV("MO"))=""
+27 ;Reset Demand Calls for this month next year
SET ASUMS("DMD","CALL",ASUV("MO"))=""
+28 IF ASUMS("EOQ","TP")'="P"
Begin DoDot:3
+29 ;Calculate new RPQ and round off to even quantity
SET ASUMS("RPQ")=$FNUMBER(((ASUMS("LTM")+ASUMS("SFSKM"))*ASUMS("PMIQ")),"-",0)
End DoDot:3
+30 ;Update Station master
DO ^ASUMSTWR
End DoDot:2
End DoDot:1
+31 QUIT
Y2K ;begin Y2K
+1 ;Y2000 CYYMM
SET X=$EXTRACT(ASUK("DT","FM"),2,5)
+2 ;Y2000
DO START^ASUUY2K(.X,1,U,"Y")
+3 ;Y2000
SET ASUDT=Y
+4 ;Y2000
SET ASUTYP="M"
+5 ;end Y2K fix block
+6 QUIT
