- ASUL07ET ; IHS/ITSC/LMH -TABLE 7 EDIT ROUTINE ;
- ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- ;This routine is a utility that provides an entry point to accept
- ;data entry to properly create an entry in the Category code Table.
- S ASUV("QUO")=""""
- G ENTER
- ASKAGAIN ;
- W !
- S DIR("A")="WANT TO EDIT ANOTHER CATEGORY TABLE ENTRY",DIR("B")="Y",DIR(0)="Y" D ^DIR K DIR
- I 'Y G DONE
- ENTER ;
- D CLS^ASUUHDG K Y
- S DIR("A")="ENTER CATEGORY NAME OR OBJECT SUB OBJECT CODE "
- S DIR("?")="^D CATNHELP^ASUL07ET"
- S DIR(0)="FO^3:60" D ^DIR K DIR
- G:$D(DUOUT)!($D(DIROUT))!($D(DTOUT)) DONE
- I X="" G ASKAGAIN
- S DIC="^ASUL(7,"
- S DIC(0)="EZM",D="C" D IX^DIC
- G:$D(DUOUT)!($D(DIROUT))!($D(DTOUT)) DONE
- I Y<0 S ASUR("ENTRY")=X W !,ASUR("ENTRY")," NOT CURRENTLY IN TABLE" G CKADD
- S ASUR("ENTRY")=X
- S ASUL(7,"CAT","E#")=+Y,ASUL(7,"CAT","NM")=Y(0),ASUL(6,"CAT","CD")=^ASUL(7,ASUL(7,"CAT","E#",1))
- I $E(ASUR("ENTRY"))=2 G DXRF
- S ASUL(7,"CAT","NM")=ASUR("ENTRY")
- S ASUL(7,"SOBJ","E#")=$O(^ASUL(7,"C",ASUL(7,"CAT","NM"),ASUL(7,"CAT","E#"),""))
- I ASUL(7,"SOBJ","E#")']"" W !,"ERROR IN NAME LOOKUP",! G ASKAGAIN
- G UPDATE
- CATNHELP ;EP ;CATEGORY NAME HELP
- S DIC="^ASUL(7,",DIC(0)="EM",D="C",DZ="??" D DQ^DICQ K DZ
- W !!,"OR YOU MAY ENTER A NEW CATEGORY NAME OR SUB OBJECT (29..) TO ADD TO THE TABLE"
- Q
- DXRF ;
- S ASUL("SOBJ")=ASUR("ENTRY")
- S ASUL(7,"SOBJ","E#")=$O(^ASUL(7,"D",ASUL("SOBJ"),ASUL(7,"CAT","E#"),""))
- I ASUL(7,"SOBJ","E#")']"" W !,"ERROR IN SUB OBJECT LOOKUP",! G ASKAGAIN
- UPDATE ;
- S DR=".01;1;2"
- S DIE="^ASUL(7,ASUL(7,""E#"",""CAT""),1,"
- S DA=ASUL(7,"SOBJ","E#"),DA(1)=ASUL(7,"CAT","E#")
- D ^DIE
- G ASKAGAIN
- CKADD ;
- S DIR("A")="DO YOU WISH TO ADD "_ASUR("ENTRY")_" AS A NEW TABLE ENTRY",DIR("B")="N",DIR(0)="Y" D ^DIR K DIR
- G:$D(DUOUT)!($D(DIROUT))!($D(DTOUT)) DONE
- I 'Y W ! G ASKAGAIN
- I $E(ASUR("ENTRY"),1,2)=29 S ASUL("SOBJ")=ASUR("ENTRY"),ASUL(7,"CAT","NM")="" G ADDIT
- S ASUL(7,"CAT","NM")=ASUR("ENTRY"),ASUL("SOBJ")=""
- ADDIT ;
- K ASUR("ENTRY")
- S DIC("A")="ENTER CATEGORY CODE FOR "_ASUL(7,"CAT","NM")_" "
- S ASUL(7,"CAT","CD")=X,DIC="^ASUL(7,",DIC(0)="AEZ",D="B" D IX^DIC
- G:$D(DUOUT)!($D(DIROUT))!($D(DTOUT)) ASKAGAIN
- I Y<0 W !," NOT FOUND" G ASKAGAIN
- S ASUL(7,"CAT","E#")=+Y
- RACC ;
- S DIR(0)="P^9002039.09:EMZ^",DIR("A")="ENTER ACCOUNT CODE" D ^DIR K DIR
- G:$D(DUOUT)!($D(DIROUT))!($D(DTOUT)) ASKAGAIN
- I Y<0 G ASKAGAIN
- S ASUL(9,"ACC")=$P(Y(0),U)
- S DR=".01///"_ASUL(7,"CAT","NM")_";1///"_ASUV("QUO")_ASUL(9,"ACC")_ASUV("QUO")
- S DR(2,902039.71,1)=".01///"_ASUV("QUO")_ASUL(9,"ACC")_ASUV("QUO")_";1//"_ASUL("SOBJ")_";2//"_ASUL(7,"CAT","CD")
- S DIE="^ASUL(7,"
- S DA=ASUL(7,"CAT","E#")
- D ^DIE
- G ASKAGAIN
- DONE ;
- K ASUL,ASUV,X,Y,DR,DA,DIC,DIE,DUOUT,DTOUT,DIROUT
- Q
- ASUL07ET ; IHS/ITSC/LMH -TABLE 7 EDIT ROUTINE ;
- +1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- +2 ;This routine is a utility that provides an entry point to accept
- +3 ;data entry to properly create an entry in the Category code Table.
- +4 SET ASUV("QUO")=""""
- +5 GOTO ENTER
- ASKAGAIN ;
- +1 WRITE !
- +2 SET DIR("A")="WANT TO EDIT ANOTHER CATEGORY TABLE ENTRY"
- SET DIR("B")="Y"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- +3 IF 'Y
- GOTO DONE
- ENTER ;
- +1 DO CLS^ASUUHDG
- KILL Y
- +2 SET DIR("A")="ENTER CATEGORY NAME OR OBJECT SUB OBJECT CODE "
- +3 SET DIR("?")="^D CATNHELP^ASUL07ET"
- +4 SET DIR(0)="FO^3:60"
- DO ^DIR
- KILL DIR
- +5 IF $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DTOUT))
- GOTO DONE
- +6 IF X=""
- GOTO ASKAGAIN
- +7 SET DIC="^ASUL(7,"
- +8 SET DIC(0)="EZM"
- SET D="C"
- DO IX^DIC
- +9 IF $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DTOUT))
- GOTO DONE
- +10 IF Y<0
- SET ASUR("ENTRY")=X
- WRITE !,ASUR("ENTRY")," NOT CURRENTLY IN TABLE"
- GOTO CKADD
- +11 SET ASUR("ENTRY")=X
- +12 SET ASUL(7,"CAT","E#")=+Y
- SET ASUL(7,"CAT","NM")=Y(0)
- SET ASUL(6,"CAT","CD")=^ASUL(7,ASUL(7,"CAT","E#",1))
- +13 IF $EXTRACT(ASUR("ENTRY"))=2
- GOTO DXRF
- +14 SET ASUL(7,"CAT","NM")=ASUR("ENTRY")
- +15 SET ASUL(7,"SOBJ","E#")=$ORDER(^ASUL(7,"C",ASUL(7,"CAT","NM"),ASUL(7,"CAT","E#"),""))
- +16 IF ASUL(7,"SOBJ","E#")']""
- WRITE !,"ERROR IN NAME LOOKUP",!
- GOTO ASKAGAIN
- +17 GOTO UPDATE
- CATNHELP ;EP ;CATEGORY NAME HELP
- +1 SET DIC="^ASUL(7,"
- SET DIC(0)="EM"
- SET D="C"
- SET DZ="??"
- DO DQ^DICQ
- KILL DZ
- +2 WRITE !!,"OR YOU MAY ENTER A NEW CATEGORY NAME OR SUB OBJECT (29..) TO ADD TO THE TABLE"
- +3 QUIT
- DXRF ;
- +1 SET ASUL("SOBJ")=ASUR("ENTRY")
- +2 SET ASUL(7,"SOBJ","E#")=$ORDER(^ASUL(7,"D",ASUL("SOBJ"),ASUL(7,"CAT","E#"),""))
- +3 IF ASUL(7,"SOBJ","E#")']""
- WRITE !,"ERROR IN SUB OBJECT LOOKUP",!
- GOTO ASKAGAIN
- UPDATE ;
- +1 SET DR=".01;1;2"
- +2 SET DIE="^ASUL(7,ASUL(7,""E#"",""CAT""),1,"
- +3 SET DA=ASUL(7,"SOBJ","E#")
- SET DA(1)=ASUL(7,"CAT","E#")
- +4 DO ^DIE
- +5 GOTO ASKAGAIN
- CKADD ;
- +1 SET DIR("A")="DO YOU WISH TO ADD "_ASUR("ENTRY")_" AS A NEW TABLE ENTRY"
- SET DIR("B")="N"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- +2 IF $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DTOUT))
- GOTO DONE
- +3 IF 'Y
- WRITE !
- GOTO ASKAGAIN
- +4 IF $EXTRACT(ASUR("ENTRY"),1,2)=29
- SET ASUL("SOBJ")=ASUR("ENTRY")
- SET ASUL(7,"CAT","NM")=""
- GOTO ADDIT
- +5 SET ASUL(7,"CAT","NM")=ASUR("ENTRY")
- SET ASUL("SOBJ")=""
- ADDIT ;
- +1 KILL ASUR("ENTRY")
- +2 SET DIC("A")="ENTER CATEGORY CODE FOR "_ASUL(7,"CAT","NM")_" "
- +3 SET ASUL(7,"CAT","CD")=X
- SET DIC="^ASUL(7,"
- SET DIC(0)="AEZ"
- SET D="B"
- DO IX^DIC
- +4 IF $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DTOUT))
- GOTO ASKAGAIN
- +5 IF Y<0
- WRITE !," NOT FOUND"
- GOTO ASKAGAIN
- +6 SET ASUL(7,"CAT","E#")=+Y
- RACC ;
- +1 SET DIR(0)="P^9002039.09:EMZ^"
- SET DIR("A")="ENTER ACCOUNT CODE"
- DO ^DIR
- KILL DIR
- +2 IF $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DTOUT))
- GOTO ASKAGAIN
- +3 IF Y<0
- GOTO ASKAGAIN
- +4 SET ASUL(9,"ACC")=$PIECE(Y(0),U)
- +5 SET DR=".01///"_ASUL(7,"CAT","NM")_";1///"_ASUV("QUO")_ASUL(9,"ACC")_ASUV("QUO")
- +6 SET DR(2,902039.71,1)=".01///"_ASUV("QUO")_ASUL(9,"ACC")_ASUV("QUO")_";1//"_ASUL("SOBJ")_";2//"_ASUL(7,"CAT","CD")
- +7 SET DIE="^ASUL(7,"
- +8 SET DA=ASUL(7,"CAT","E#")
- +9 DO ^DIE
- +10 GOTO ASKAGAIN
- DONE ;
- +1 KILL ASUL,ASUV,X,Y,DR,DA,DIC,DIE,DUOUT,DTOUT,DIROUT
- +2 QUIT
