Routine: BUSATRAN

BUSATRAN ;GDIT/HS/ALA-Update RPCs for transport ; 02 Apr 2013  2:20 PM

 ;;1.0;IHS USER SECURITY AUDIT;;Nov 05, 2013;Build 65

EN ;EP - entry point

 NEW DIC,DIE,DR,DA,DTOUT,DIRUT,DUOUT,X,Y,BRPCN,DLAYGO,CURRIEN,QUIT,CURRRPC

EN1 I $G(IOF)="" D HOME^%ZIS

 W @IOF

 ;Get RPC

 S DIC="^XWB(8994,",DIC(0)="AEMNZ"

 D ^DIC S BRPCN=+Y I BRPCN<1 Q

 I $G(DTOUT)!($G(DIRUT))!($G(DUOUT)) Q

 ;See if already exists

 S DIC="^BUSATR(",DIC(0)="MNZ",X=$P(^XWB(8994,BRPCN,0),U,1),DLAYGO=9002319.07

 D ^DIC

 S CURRIEN=+Y,CURRRPC=+$P(Y,U,2)

 S QUIT=1

 ;Check for adds

 I CURRIEN<0 D  G:'QUIT EN1

 . NEW DIR,X,Y

 . S DIR("A")="Add entry to transport list",DIR("B")="Yes"

 . S DIR(0)="Y"

 . D ^DIR

 . S QUIT=Y

 ;Check for edits/deletes

 I CURRIEN>0 D  G:'QUIT EN1

 . NEW DIR,X,Y,DA,DIK

 . S DIR(0)="SO^E:Edit Transport Entry;D:Delete Transport Entry"

 . S DIR("A")="Choose operation to perform"

 . S DIR("B")="E"

 . D ^DIR

. ;

 . ;Edits

 . Q:Y="E"

. ;

 . ;Quits

 . I Y'="D" S QUIT=0 Q

. ;

 . ;Deletes

 . S DIR("A")="Are you sure you wish to delete the entry",DIR("B")="No"

 . S DIR(0)="Y"

 . D ^DIR

 . S QUIT=Y Q:'QUIT

 . S DA=CURRIEN,DIK="^BUSATR(" D ^DIK

 . W !,"TRANSPORT ENTRY DELETED..."

 . S QUIT=0

 . S DIR("A")="Do you wish to delete the BUSA RPC definition entry as well",DIR("B")="No"

 . S DIR(0)="Y"

 . D ^DIR

 . S QUIT=Y Q:'QUIT

 . S DA=CURRRPC,DIK="^BUSA(9002319.03," D ^DIK

 . W !,"BUSA RPC DEFINITION DELETED..." H 2

 . S QUIT=0

 ;Add/Edits

 S DIC="^BUSATR(",DIC(0)="LMNZ",X=$P(^XWB(8994,BRPCN,0),U,1),DLAYGO=9002319.07

 D ^DIC

 I $G(DTOUT)!($G(DIRUT))!($G(DUOUT)) Q

 S DA=+Y,DIE=DIC,DR="[BUSA UPDATE]"

 D ^DIE

 G EN1

CONV ;EP - Convert the pointers to text

 NEW BUSN,BUSRN,BUSUPD

 S BUSN=0

 F  S BUSN=$O(^BUSA(9002319.03,BUSN)) Q:'BUSN  D

 . S BUSRN=$P(^BUSA(9002319.03,BUSN,0),U,1)

 . I BUSRN'?.N Q

 . S BUSUPD(9002319.03,BUSN_",",.01)=$P(^XWB(8994,BUSRN,0),U,1)

 ;D FILE^DIE("","BUSUPD","ERROR")

BUSATRAN  ;GDIT/HS/ALA-Update RPCs for transport ; 02 Apr 2013  2:20 PM

 +1       ;;1.0;IHS USER SECURITY AUDIT;;Nov 05, 2013;Build 65

 +2       ;

EN        ;EP - entry point

 +1       ;

 +2        NEW DIC,DIE,DR,DA,DTOUT,DIRUT,DUOUT,X,Y,BRPCN,DLAYGO,CURRIEN,QUIT,CURRRPC

 +3       ;

EN1        IF $GET(IOF)=""

               DO HOME^%ZIS

 +1        WRITE @IOF

 +2       ;

 +3       ;Get RPC

 +4        SET DIC="^XWB(8994,"

           SET DIC(0)="AEMNZ"

 +5        DO ^DIC

           SET BRPCN=+Y

           IF BRPCN<1

               QUIT

 +6        IF $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))

               QUIT

 +7       ;

 +8       ;See if already exists

 +9        SET DIC="^BUSATR("

           SET DIC(0)="MNZ"

           SET X=$PIECE(^XWB(8994,BRPCN,0),U,1)

           SET DLAYGO=9002319.07

 +10       DO ^DIC

 +11       SET CURRIEN=+Y

           SET CURRRPC=+$PIECE(Y,U,2)

 +12       SET QUIT=1

 +13      ;

 +14      ;Check for adds

 +15       IF CURRIEN<0

               Begin DoDot:1

 +16               NEW DIR,X,Y

 +17               SET DIR("A")="Add entry to transport list"

                   SET DIR("B")="Yes"

 +18               SET DIR(0)="Y"

 +19               DO ^DIR

 +20               SET QUIT=Y

               End DoDot:1

               IF 'QUIT

                   GOTO EN1

 +21      ;

 +22      ;Check for edits/deletes

 +23       IF CURRIEN>0

               Begin DoDot:1

 +24               NEW DIR,X,Y,DA,DIK

 +25               SET DIR(0)="SO^E:Edit Transport Entry;D:Delete Transport Entry"

 +26               SET DIR("A")="Choose operation to perform"

 +27               SET DIR("B")="E"

 +28               DO ^DIR

 +29      ;

 +30      ;Edits

 +31               IF Y="E"

                       QUIT

 +32      ;

 +33      ;Quits

 +34               IF Y'="D"

                       SET QUIT=0

                       QUIT

 +35      ;

 +36      ;Deletes

 +37               SET DIR("A")="Are you sure you wish to delete the entry"

                   SET DIR("B")="No"

 +38               SET DIR(0)="Y"

 +39               DO ^DIR

 +40               SET QUIT=Y

                   IF 'QUIT

                       QUIT

 +41               SET DA=CURRIEN

                   SET DIK="^BUSATR("

                   DO ^DIK

 +42               WRITE !,"TRANSPORT ENTRY DELETED..."

 +43               SET QUIT=0

 +44               SET DIR("A")="Do you wish to delete the BUSA RPC definition entry as well"

                   SET DIR("B")="No"

 +45               SET DIR(0)="Y"

 +46               DO ^DIR

 +47               SET QUIT=Y

                   IF 'QUIT

                       QUIT

 +48               SET DA=CURRRPC

                   SET DIK="^BUSA(9002319.03,"

                   DO ^DIK

 +49               WRITE !,"BUSA RPC DEFINITION DELETED..."

                   HANG 2

 +50               SET QUIT=0

               End DoDot:1

               IF 'QUIT

                   GOTO EN1

 +51      ;

 +52      ;Add/Edits

 +53       SET DIC="^BUSATR("

           SET DIC(0)="LMNZ"

           SET X=$PIECE(^XWB(8994,BRPCN,0),U,1)

           SET DLAYGO=9002319.07

 +54       DO ^DIC

 +55       IF $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))

               QUIT

 +56       SET DA=+Y

           SET DIE=DIC

           SET DR="[BUSA UPDATE]"

 +57       DO ^DIE

 +58       GOTO EN1

 +59      ;

CONV      ;EP - Convert the pointers to text

 +1        NEW BUSN,BUSRN,BUSUPD

 +2        SET BUSN=0

 +3        FOR

               SET BUSN=$ORDER(^BUSA(9002319.03,BUSN))

               IF 'BUSN

                   QUIT

               Begin DoDot:1

 +4                SET BUSRN=$PIECE(^BUSA(9002319.03,BUSN,0),U,1)

 +5                IF BUSRN'?.N

                       QUIT

 +6                SET BUSUPD(9002319.03,BUSN_",",.01)=$PIECE(^XWB(8994,BUSRN,0),U,1)

               End DoDot:1

 +7       ;D FILE^DIE("","BUSUPD","ERROR")

 +8        QUIT

BUSATRAN.m