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

ASURO800.m

Go to the documentation of this file. 
  1. ASURO800 ; IHS/ITSC/LMH -RPT 80 ISS-ANAL SELECT ACCOUNTS ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;This routine sorts report 80 extracts into proper sequence so that the
  1.  ;report can be formatted and printed.
  1.  D:'$D(IO) HOME^%ZIS
  1.  I $D(^XTMP("ASUR","R80")) D
  1.  .S DIR("A")="Use Last Report 80 Selections",DIR(0)="Y",DIR("?")="^D LASL^ASURO80" D ^DIR K DIR
  1.  E  S Y=0
  1.  I $D(DTOUT)!($D(DUOUT)) Q
  1.  I Y Q
  1. EN1 ;EP;SELECT NEW PARAMETERS
  1.  S ASUT="R80"
  1.  K ^XTMP("ASUR","R80")
  1.  S ^XTMP("ASUR","R80",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
  1.  S ASUF("ALL","ACC")=0,DIR("A")="Report on all Accounts",DIR(0)="Y" D ^DIR Q:$D(DUOUT)  Q:$D(DTOUT)
  1.  I Y D
  1.  .S ASUF("ALL","ACC")=1 K DIR
  1.  .F X=0:0 S X=$O(^ASUL(9,X)) Q:X'?1N.N  S ^XTMP("ASUR","R80",0,X)=X_U_$P(^ASUL(9,X,0),U)
  1.  E  D
  1.  .K DIR
  1.  .F  D  Q:$D(DTOUT)!($D(DUOUT))!(Y<0)
  1.  ..S DIR("A")="Report for what Account",DIR(0)="PO^9002039.09:MXEZ",DIR("?")="Enter valid Account Code " D ^DIR
  1.  ..I $D(DTOUT)!($D(DUOUT)!(Y<0)) Q
  1.  ..S ^XTMP("ASUR","R80",0,+Y)=Y
  1.  I $D(DTOUT)!($D(DUOUT)) Q
  1.  S ASUT(ASUT,"ACC")=""
  1.  F  S ASUT(ASUT,"ACC")=$O(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"))) Q:ASUT(ASUT,"ACC")']""  D ASURO801
  1.  S ASUF("OK")=1
  1.  S DIR(0)="Y",DIR("A")="Do you want to review your selections" D ^DIR
  1.  I Y D
  1.  .D SEL
  1.  .W !!,"In answering the following, a response of 'Y' will process your Selections"
  1.  .W !,"An answer of 'N' will erase your selections and allow you to enter new ones",!
  1.  .S DIR("A")="Are selections OK"
  1.  .D ^DIR
  1.  .K DIR
  1.  .I Y D
  1.  ..S ASUF("OK")=1
  1.  .E  D
  1.  ..S ASUF("OK")=0
  1.  I $D(DUOUT)!($D(DTOUT)) K ^XTMP("ASUR","R80") Q
  1.  I 'ASUF("OK") G EN1
  1.  W !!,"Gathering Data for your Selections",!
  1.  S ASUMX("E#","IDX")=0
  1.  F  S ASUMX("E#","IDX")=$O(^ASUMX(ASUMX("E#","IDX"))) Q:ASUMX("E#","IDX")'?1N.N  D
  1.  .D READ^ASUMXDIO Q:ASUMX("CAT")']""
  1.  .I $D(^XTMP("ASUR","R80",0,ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"))) D
  1.  ..W "."
  1.  ..S ^XTMP("ASUR","R80",1,ASUMX("IDX"))=ASUMX("E#","IDX")
  1.  D:'$D(ASUK("DT","FM")) ^ASUUDATE
  1.  S ^XTMP("ASUR","R80",2)=ASUK("DT","FM")
  1.  D ASURO803
  1.  K X,ASUF("ALL")
  1.  Q
  1. ASURO801 ;
  1.  I ASUF("ALL","ACC") D
  1.  .S Y=1
  1.  E  D
  1.  .S DIR("A")="Report on all Object Sub-Objects for Account "_ASUT(ASUT,"ACC"),DIR(0)="Y" D ^DIR
  1.  I $D(DTOUT)!($D(DUOUT)) Q
  1.  I Y D
  1.  .S ASUF("ALL","OBJ")=1 K X,DIR
  1.  .F Y=0:0 S Y=$O(^ASUL(3,Y)) Q:Y'?1N.N  D
  1.  ..S (ASUT(ASUT,"SOBJ"),X)=^ASUL(3,Y,1) D SCROBJ Q:'$T
  1.  ..S ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"))=Y_U_^ASUL(3,Y,0)
  1.  E  D
  1.  .F  D  Q:$D(DTOUT)!($D(DUOUT))!(ASUT(ASUT,"SOBJ")="")
  1.  ..S ASUF("ALL","OBJ")=0,DIR(0)="PO^9002039.03:MXZEA",DIR("A")="Select Object Sub-Object: ",ASUT("TRCD")=""
  1.  ..D READOBJ I $D(DUOUT)!($D(DTOUT))!(ASUT(ASUT,"SOBJ")="") Q
  1.  ..D SSO^ASULDIRF(ASUL(3,"SOBJ","E#"))
  1.  ..S ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"))=ASUL(3,"SOBJ","E#")_U_ASUL(3,"SOBJ","NM")
  1.  .K DIR,X,Y
  1.  S ASUT(ASUT,"SOBJ")=""
  1.  F  S ASUT(ASUT,"SOBJ")=$O(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"))) Q:ASUT(ASUT,"SOBJ")']""  D ASURO802
  1.  Q
  1. ASURO802 ;
  1.  S ASUL(3,"SOBJ","E#")=$P(^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ")),U)
  1.  I ASUT(ASUT,"ACC")=$G(ASUV("ACC")) D
  1.  .S ASUV("ACC")=ASUT(ASUT,"ACC") W !,"PROCESSING ACCOUNT: ",ASUT(ASUT,"ACC")
  1.  I ASUF("ALL","OBJ") D
  1.  .S Y=1
  1.  E  D
  1.  .S DIR("A")="Report on all Categorys for Ofject Sub-Object "_ASUT(ASUT,"SOBJ"),DIR(0)="Y" D ^DIR
  1.  I $D(DTOUT)!($D(DUOUT)) Q
  1.  I Y D
  1.  .K X,Y,DIR
  1.  .S ASUF("ALL","CAT")=1,Y=ASUL(3,"SOBJ","E#")_"00"
  1.  .F  S Y=$O(^ASUL(7,Y)) Q:ASUL(3,"SOBJ","E#")'=$E(Y,1,3)  D
  1.  ..S (ASUL(7,"CAT","CD"),X)=$P(^ASUL(7,Y,1),U)
  1.  ..S ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"),ASUL(7,"CAT","CD"))=Y_U_^ASUL(7,Y,0)
  1.  E  D
  1.  .S ASUF("ALL","CAT")=0
  1.  .F  D  Q:$G(ASUT(ASUT,"CAT"))']""!($D(DTOUT))!($D(DUOUT))
  1.  ..S DIR("A")="Select Category: ",ASUS("OPTN")="PO" D READCAT Q:ASUT(ASUT,"CAT")']""
  1.  ..D CAT^ASULDIRF(ASUL(7,"CAT","E#"))
  1.  ..I $D(DUOUT)!($D(DTOUT)) Q
  1.  ..S ^XTMP("ASUR","R80",0,ASUT(ASUT,"ACC"),ASUT(ASUT,"SOBJ"),ASUL(7,"CAT","CD"))=ASUL(7,"CAT","E#")_U_ASUL(7,"CAT","NM")
  1.  K DIR,X,Y
  1.  Q
  1. ASURO803 ;
  1.  S ASUL(2,"STA","E#")=$G(ASUL(1,"AR","STA1"))
  1.  I ASUL(2,"STA","E#")']"" W !,"SORRY, YOU AREA NOT AUTHORIZED TO RUN THIS REPORT" K DIR S DIR(0)="E" D ^DIR S DUOUT=1 Q
  1.  D STA^ASULARST(ASUL(2,"STA","E#"))
  1.  S ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"))=ASUL(1,"AR","NM")
  1.  S ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUL(2,"STA","E#"))=ASUL(2,"STA","NM")_U_ASUL(2,"STA","CD")
  1.  S ASUX("IDX")=""
  1.  F  S ASUX("IDX")=$O(^XTMP("ASUR","R80",1,ASUX("IDX"))) Q:ASUX("IDX")']""  D
  1.  .S ASUMK("E#","STA")="",ASUMK("E#","IDX")=^XTMP("ASUR","R80",1,ASUX("IDX"))
  1.  .F  S ASUMK("E#","STA")=$O(^ASUMK("C",ASUMK("E#","IDX"),ASUMK("E#","STA"))) Q:ASUMK("E#","STA")']""  D
  1.  ..W "."
  1.  ..S ASUMK("E#","REQ")=""
  1.  ..F  S ASUMK("E#","REQ")=$O(^ASUMK("C",ASUMK("E#","IDX"),ASUMK("E#","STA"),ASUMK("E#","REQ"))) Q:ASUMK("E#","REQ")']""  D IBMST
  1.  Q
  1. IBMST ;
  1.  D READ^ASUMKBIO
  1.  S ASUL(18,"E#","SST")=$E(ASUMK("E#","REQ"),1,5) D SST^ASULDIRR(ASUL(18,"E#","SST")),REQ^ASULDIRR(ASUMK("E#","REQ"))
  1.  S ASUMX("E#","IDX")=^XTMP("ASUR","R80",1,ASUMK("IDX"))
  1.  D READ^ASUMXDIO
  1.  S $P(^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),ASUL(18,"E#","SST")),U)=ASUL(18,"SST","NM")
  1.  S ASUX(2)=^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),ASUL(18,"E#","SST"))
  1.  S $P(ASUX(2),U,2)=$P(ASUX(2),U,2)+ASUMK("CFY","VAL")
  1.  S $P(ASUX(2),U,3)=$P(ASUX(2),U,3)+ASUMK("PFY","VAL")
  1.  S $P(ASUX(2),U,4)=$P(ASUX(2),U,4)+ASUMK("PPY","VAL")
  1.  S ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1),+ASUL(18,"E#","SST"))=ASUX(2)
  1.  S $P(^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1)),U,4)=ASUMX("E#","IDX")
  1.  S ASUX=^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1))
  1.  S $P(ASUX,U)=$P(ASUX,U)+ASUMK("CFY","VAL")
  1.  S $P(ASUX,U,2)=$P(ASUX,U,2)+ASUMK("PFY","VAL")
  1.  S $P(ASUX,U,3)=$P(ASUX,U,3)+ASUMK("PPY","VAL")
  1.  S $P(ASUX,U,5)=ASUMX("IDX")
  1.  S $P(ASUX,U,6)=ASUMX("DESC",2)
  1.  S ^XTMP("ASUR","R80",2,ASUL(2,"STA","E#"),ASUMX("ACC"),ASUMX("SOBJ"),ASUMX("CAT"),ASUMX("DESC",1))=ASUX
  1.  Q
  1. ASURO805 ;
  1. LASL ;LIST LAST REPORT 80'S SELECTIONS
  1.  S ASUC=0
  1.  W !,"Last Selection(s) were:" S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
  1.  G CONTU
  1. SEL ;LIST REPORT 80 SELECTIONS
  1.  S ASUC=0
  1.  W !,"Your Selection(s) are:" S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
  1. CONTU ;
  1.  F  S ASUL=$O(^XTMP("ASUR","R80",0,$G(ASUL))) Q:ASUL']""  D  Q:$D(DTOUT)!($D(DUOUT))
  1.  .W !?2,"Account: ",ASUL," ",$P(^XTMP("ASUR","R80",0,ASUL),U,2) S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
  1.  .F  S ASUA(1)=$O(^XTMP("ASUR","R80",0,ASUL,$G(ASUA(1)))) Q:ASUA(1)']""  D  Q:$D(DTOUT)!($D(DUOUT))
  1.  ..W !?4,"Object Sub Object: ",ASUA(1)," ",$P(^XTMP("ASUR","R80",0,ASUL,ASUA(1)),U,2) S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
  1.  ..F  S ASUA(2)=$O(^XTMP("ASUR","R80",0,ASUL,ASUA(1),$G(ASUA(2)))) Q:ASUA(2)']""  D  Q:$D(DTOUT)!($D(DUOUT))
  1.  ...W !?6,"Category: ",ASUA(2)," ",$P(^XTMP("ASUR","R80",0,ASUL,ASUA(1),ASUA(2)),U,2) S ASUC=ASUC+1 D PAUSE Q:$D(DTOUT)!($D(DUOUT))
  1.  K ASUC,ASUF,ASUMX,ASUMS,ASUT,ASUV,ASUX
  1.  Q
  1. PAUSE ;EP;PAUSE AT END OF SCREEN
  1.  Q:ASUC<IOSL
  1.  N DIR
  1.  S DIR(0)="E" D ^DIR
  1.  S ASUC=0
  1.  Q
  1. READOBJ ;READ OBJECT SUB OBJECT CODE
  1.  I ASUT(ASUT,"ACC")="" S ASUT(ASUT,"SOBJ")="" W !,DIR("A"),":" Q
  1.  S DIR("S")="D SCROBJ^ASURO800"
  1.  S DIR("?")="Object-Sub-Object not valid for Account "_ASUT(ASUT,"ACC")
  1.  D ASU0EDIR
  1.  I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) Q
  1.  I Y<0 D
  1.  .S (ASUL(3,"SOBJ","E#"),ASUT(ASUT,"SOBJ"))=""
  1.  E  D
  1.  .S ASUL(3,"SOBJ","E#")=+Y
  1.  .S ASUV("SOBJ","NM")=$P(Y,U,2)
  1.  .S ASUT(ASUT,"SOBJ")=$P(^ASUL(3,ASUL(3,"SOBJ","E#"),1),U)
  1.  .I ASUT("TRCD")="4C" S ASUS("CHG")=1
  1.  K DIR,X,Y
  1.  Q
  1. SCROBJ ;EP ;SCREEN
  1.  I $E(Y)=ASUT(ASUT,"ACC")
  1.  Q
  1. READCAT ;EP; READ CATEGORY
  1.  N DIR,X,Y
  1.  S DIR("S")="D SCRCAT^ASURO800"
  1.  S DIC("W")="W ?70,"" "",$P(^(1),U)"
  1.  S DIR("?")="Category not valid for Account "_ASUT(ASUT,"ACC")_" and Object-Sub-Object "_ASUT(ASUT,"SOBJ")
  1.  I $G(ASUS("OPTN"))']"" D
  1.  .S ASUS("OPTN")="PO"
  1.  .I ASUT(ASUT,"ACC")]"",ASUT(ASUT,"SOBJ")]"" S ASUS("OPTN")="P"
  1.  S DIR(0)=ASUS("OPTN")_"^9002039.07:MXZA" K ASUS("OPTN")
  1.  D ASU0EDIR
  1.  I $D(DUOUT)!($D(DIROUT))!($D(DTOUT)) Q
  1.  I Y>0 D
  1.  .S ASUL(7,"CAT","E#")=+Y,ASUT(ASUT,"CAT NM")=$P(Y,U,2)
  1.  .S ASUT(ASUT,"CAT")=$P(^ASUL(7,ASUL(7,"CAT","E#"),1),U)
  1.  .W " ",ASUT(ASUT,"CAT")," ",ASUT(ASUT,"CAT NM")
  1.  E  D
  1.  .S ASUT(ASUT,"CAT")=""
  1.  I ASUT(ASUT,"CAT")]"" S:ASUT("TRCD")="4C" ASUS("CHG")=1
  1.  Q
  1. SCRCAT ;SCREENING LOGIC
  1.  I $E(Y)=ASUL(9,"ACC","E#"),$E(Y,1,3)=ASUL(3,"SOBJ","E#")
  1.  Q
  1. ASU0EDIR ;
  1.  N X
  1.  S:$D(DIR("S")) DIC("S")=DIR("S")
  1.  S DIC("A")=DIR("A")
  1.  I $D(DIR("B")) W DIR("B"),"// " S DIC("B")=DIR("B")
  1.  S DIC=$P($P(DIR(0),U,2),":")
  1.  S:DIC'?1N.E DIC=U_DIC
  1.  S DIC(0)=$P($P(DIR(0),U,2),":",2)
  1.  I $P(DIR(0),U)'["O" D
  1.  .F  D ^DIC Q:$D(DTOUT)!($D(DUOUT))  Q:+Y>0  W "   Field is Required",!
  1.  E  D
  1.  .D ^DIC
  1.  K DIC
  1.  Q