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")
Q
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
