- 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
