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

ASUCOHKP.m

Go to the documentation of this file. 
  1. ASUCOHKP ; IHS/ITSC/LMH -UPDATE HOUSEKEEPING ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;This routine initializes necessary files/variables before any update
  1.  ;run. (Housekeeping)
  1.  S ASUP("CKT")=+$G(ASUP("CKT"))
  1.  ;WAR 6/25/99 REM'D NEXT LINE & ADDED NEXT LINES
  1.  ;S ASUP("CKT")=1 D SETST^ASUCOSTS
  1.  S ASUP("CKT")=1
  1.  I $G(ASUK("HDG","MENU"))["DAILY" S ASUP("CKT")=""
  1.  D SETST^ASUCOSTS
  1.  D DATE^ASUUDATE,TIME^ASUUDATE
  1.  S ASURX="W !,""S.A.M.S. Closeout Housekeeping Procedure Begun "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
  1.  D:$G(ASUN("TYP"))']"" ^ASUURANG
  1.  S:+($G(ASUP("CKP")))=0 ASUP("CKP")=1
  1.  I ASUP("CKP")=1 D  ;Clear deleted masters
  1.  .D IBMCLR Q:$G(ASUP("HLT"))>0  S ASUP("CKP")=2 D SETSP^ASUCOSTS
  1.  I ASUP("CKP")=2 D  ;Clear report files
  1.  .D RPTCLR Q:$G(ASUP("HLT"))>0  S ASUP("CKP")=3 D SETSP^ASUCOSTS
  1.  I ASUP("CKP")=3 D  ;Get beginning balances
  1.  .D BALANCE Q:$G(ASUP("HLT"))>0  S ASUP("CKP")=0 D SETSP^ASUCOSTS
  1.  D DATE^ASUUDATE,TIME^ASUUDATE
  1.  S ASURX="W !,""S.A.M.S. Closeout Housekeeping Procedure Ended "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
  1.  Q
  1. IBMCLR ;CLEAR ISSUE BOOK MASTERS FOR PREVIOUSLY DELETED RECORDS
  1.  D:'$D(U) ^XBKVAR
  1.  S ASURX="W !?3,""Removing Deleted Indexes from Issue Book Masters File""" D ^ASUUPLOG
  1.  K ASUMX S ASUMX("IDX")=""
  1.  F  S ASUMX("IDX")=$O(^ASUMX("B",999999,ASUMX("IDX"))) Q:ASUMX("IDX")']""  Q:ASUMX("IDX")["999999"  D  ;Look at all deleted index masters
  1.  .S ASUMK("SST")=$O(^ASUMK("C",ASUMX("IDX"),"")) ;Find first Sub Station using deleted index
  1.  .Q:ASUMK("SST")']""  ;No Substations using this index
  1.  .S ASUMK("SST")=ASUMK("SST")-1 ;Begin with first substation
  1.  .F  S ASUMK("SST")=$O(^ASUMK("C",ASUMX("IDX"),ASUMK("SST"))) Q:ASUMK("SST")']""  D
  1.  ..S ASUMK("REQ")="" S ASUMK("REQ")=$O(^ASUMK("C",ASUMX("IDX"),ASUMK("SST"),ASUMK("REQ"))) Q:ASUMK("SST")']""  D  ;Find all requsitioners
  1.  ...S ASUC("CLRX")=$G(ASUC("CLRX"))+1
  1.  ...F X=0,1,2 K ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,ASUMX("IDX"),X)
  1.  ...K ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,"B",ASUMX("IDX"),ASUMX("IDX"))
  1.  ...K ^ASUMK("C",ASUMX("IDX"),ASUMK("SST"),ASUMK("REQ"),ASUMX("IDX"))
  1.  ...S ASUC("IDX")=$P(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0),U,4)
  1.  ...S ASUC("IDX")=ASUC("IDX")-1
  1.  ...S $P(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0),U,4)=ASUC("IDX")
  1.  ...I ASUC("IDX")=0 D
  1.  ....S X=$O(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0))
  1.  ....Q:X]""
  1.  ....S ASUC("CLRU")=$G(ASUC("CLRU"))+1
  1.  ....K ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"))
  1.  ....K ^ASUMK(ASUMK("SST"),1,"B",ASUMK("REQ"),ASUMK("REQ"))
  1.  ....S ASUC("REQ")=$P(^ASUMK(ASUMK("SST"),1,0),U,4)
  1.  ....S ASUC("REQ")=ASUC("REQ")-1
  1.  ....S $P(^ASUMK(ASUMK("SST"),1,0),U,4)=ASUC("REQ")
  1.  ....I ASUC("REQ")=0 D
  1.  .....I X']"" S ASURX="W !,""Sub Station "_ASUMK("SST")_" may be deleted""" D ^ASUUPLOG
  1.  S ASURX="W !?10,"_+($G(ASUC("CLRX")))_","" Issue Book Index Master Records Cleared""" D ^ASUUPLOG
  1.  S ASURX="W !?10,"_+($G(ASUC("CLRU")))_","" Issue Book User Master Records Cleared""" D ^ASUUPLOG
  1.  K ASUC("CLRX"),ASUC("IDX"),ASUMK,ASURX
  1.  Q
  1.  S ASUV("IDX")="" ;K ^ASUD("DIX")
  1.  F  S ASUV("IDX")=$O(^ASUMX("D",ASUV("IDX"))) Q:ASUV("IDX")']""  D
  1.  .S ASUMX("E#","IDX")=$O(^ASUMX("D",ASUV("IDX"),""))
  1.  .Q:$P(^ASUMX(ASUMX("E#","IDX"),2),U,3)]""
  1.  .D READ^ASUMXDIO S ASUMX("DELDT")=ASUK("DT","FM") D WRITE^ASUMXDIO
  1.  .;S ^ASUD("DIX",ASUMX("E#","IDX"))=""
  1. RPTCLR ;UPDATE CLEAR REPORT GLOBALS
  1.  ;This sub-routine clears the XTMP globals which contain pointers to
  1.  ;data to be placed on the reports to be created for this closeout.
  1.  S ASURX="W !?3,""Clearing Report and Beginning Balance Files""" D ^ASUUPLOG
  1.  K ^XTMP("ASUMA")
  1.  S ASUV("RDT")=$E(ASUK("DT","FM"),1,5)+100_"01"_U_ASUK("DT","FM") S ^XTMP("ASUMA",0)=ASUV("RDT")
  1.  N X F X="70","7I","71","72","73","01","07","08","09","10A","10","11","13" D
  1.  .S X="R"_X K ^XTMP("ASUR",X) S ^XTMP("ASUR",X,0)=ASUV("RDT")
  1.  I $G(ASUP("TYP"))=1,$G(ASUP("OLIB"))]"" D VOUCHER
  1.  Q
  1. VOUCHER ;RESET VOUCHER NUMBER
  1.  S $P(^ASUSITE(1,1),U,8)=$P(^ASUSITE(1,3),U,8)
  1.  Q
  1. BALANCE ;UPDATE ACTIVE/INACTIVE OPENING BALANCE FILE AND REPORT 1 BALANCES
  1.  D SELSTA,LOADDAY
  1.  D ^ASUMCUPD
  1.  Q
  1. SELSTA ;
  1.  S (ASUC("STA"),ASUC("ACT"))=0
  1.  S (ASUMX("E#","IDX"),ASUMS("E#","STA"))=0
  1.  S ASURX="W !?3,""Getting Beginning Balances (R11) and Counts (R1)""" D ^ASUUPLOG
  1.  I $G(ASUL(2,"STA","E#"))]"" S ASUMS("E#","STA")=ASUL(2,"STA","E#") D MSTLOOP Q
  1.  F  S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:ASUMS("E#","STA")'?5N  D MSTLOOP
  1.  Q
  1. MSTLOOP ;
  1.  K ^XTMP("ASUMA")
  1.  S ASURX="W !?3,""Cataloging All Masters""" D ^ASUUPLOG
  1.  S ASUMS("E#","IDX")=0
  1.  F  S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")'?8N  D
  1.  .I $P(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),0),U)[999999 Q  ;Deleted master
  1.  .S ASUMX("E#","IDX")=ASUMS("E#","IDX")
  1.  .D ^ASUMXDIO,^ASUMSTRD ;Read Index and Station masters
  1.  .S ^XTMP("ASUMA",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"))=""
  1.  .S ^TMP("ASUMC",$J,ASUL(9,"ACC"),ASUMS("E#","IDX"))=""
  1.  Q
  1. LOADDAY ;
  1.  S ASURX="W !?3,""Getting Today's Master Beginning Balances""" D ^ASUUPLOG
  1.  S ASUMS("E#","STA")=ASUL(2,"STA","E#")
  1.  D:$G(ASUN("TYP"))']"" RANGE^ASUURANG(1)
  1.  D LOAD(.ASUN)
  1.  Q
  1. LOAD(Y) ;EP; LOAD BEGINNING BALANCES
  1.  S Y("ACC")=0
  1.  F  S Y("ACC")=$O(^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC"))) Q:Y("ACC")']""  D
  1.  .S Y("IDX")=0
  1.  .F  S Y("IDX")=$O(^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC"),Y("IDX"))) Q:Y("IDX")']""  D
  1.  ..N X S X=^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC"),Y("IDX"))
  1.  ..I Y("B#")]"" D
  1.  ...I $D(^ASUH("I",Y("IDX"),Y("B#"))) S Y=Y("B#")
  1.  ...E  S Y=$O(^ASUH("I",Y("IDX"),Y("B#"))) ;First tran today
  1.  ..E  S Y=""
  1.  ..I Y]"",Y'>Y("E#") S X="A",X("DA")=Y
  1.  ..E  S X="I"
  1.  ..I Y("B#")]"" D
  1.  ...S Y=$O(^ASUH("I",Y("IDX"),Y("B#")),-1) ;Most recent tran
  1.  ..E  S Y=""
  1.  ..I Y]"" S ASUFB=1
  1.  ..E  S ASUFB=0 S:X="A" Y=$G(X("DA"))
  1.  ..I Y?1N.N D
  1.  ...Q:$P(^ASUH(Y,0),U,3)'=ASUL(2,"STA","E#")
  1.  ...D READ^ASU0TRRD(.Y,"H")
  1.  ...Q:ASUT("TYPE")=7  ;Direct issue - not masters
  1.  ...S X("VAL")=(+ASUT(ASUT,"MST","VAL"))
  1.  ...S X("QTY")=(+ASUT(ASUT,"MST","QTY"))
  1.  ...S X("D/I")=(+ASUT(ASUT,"MST","D/I"))
  1.  ...S X("ACC")=ASUT(ASUT,"ACC")
  1.  ...I ASUFB=0 D  ;First of current day's transaction being used
  1.  ....Q:ASUT("TYPE")=4  Q:ASUT("TYPE")=5  ;Index and Station masters - no effect on balance
  1.  ....I ASUT("TYPE")=1 S X("D/I")=X("D/I")-(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN")) Q  ;Due in - due in quantity effected
  1.  ....I ASUT("TYPE")=3 S X("QTY")=X("QTY")-(ASUT(ASUT,"QTY","ISS")*ASUT(ASUT,"SIGN")),X("VAL")=X("VAL")-(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN")) Q  ;Issue - Quantity and Value effected
  1.  ....S X("QTY")=X("QTY")-(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN")),X("VAL")=X("VAL")-(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN")) ;Receipt,Adjustments and Transfers - Quantity and Value effected
  1.  ..E  D
  1.  ...K ASUMS,ASUMX D IDX^ASUMXDIO(Y("IDX")),READ^ASUMSTRD(Y("IDX"))
  1.  ...S X("VAL")=+ASUMS("VAL","O/H"),X("QTY")=+ASUMS("QTY","O/H"),X("D/I")=+ASUMS("D/I","QTY-TOT"),X("ACC")=$G(ASUMX("ACC")) ;Save balances from Station master
  1.  ..I Y("TYP")="1" D
  1.  ...S X=X_U_$G(X("VAL"))_U_$G(X("QTY"))_U_$G(X("D/I"))_U_$S($G(X("ACC"))]"":X("ACC"),1:Y("ACC"))_U_$G(X("DA"))_U_$G(ASUFB)
  1.  ...S ^XTMP("ASUMA",ASUMS("E#","STA"),ASUL(9,"ACG"),Y("IDX"))=X
  1.  ..E  D
  1.  ...S ^TMP("ASUMC",$J,ASUL(9,"ACC"),Y("IDX"))=$G(X("VAL"))
  1.  Q