PSXBPOST.m

PSXBPOST ;BIR/HTW-Post Initialization Routine;8/15/95 [ 08/25/95  3:28 PM ]

 ;;1.0;CONSOLIDATED MAIL OUTPATIENT PHARMACY;**2**;10 May 95

 N I,NAME,DIE,DR,DA

REM F I="PSX ARCHIVE","PSX ARCHIVE PURGE","PSX ARCHIVE RETRIEVE","PSX ARCHIVE SAVE" D

 .S DA=$O(^DIC(19,"B",I,0)) Q:'DA

 .S DIK="^DIC(19," D ^DIK

  K DIK,DA

 F I="PSXB ARCHIVE","PSXB ARCHIVE PURGE","PSXB ARCHIVE RETRIEVE","PSXB ARCHIVE SAVE" D

 .S NAME="PSX"_$P(I,"B",2),DA=$O(^DIC(19,"B",I,0)) Q:'DA

 .S DIE="^DIC(19,",DR=".01////"_NAME

 .D ^DIE

 .W !,"Option ",I," renamed ",NAME

 W !!,"Installation complete!"

 K DA,NAME,DIE,DR,I

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSXBPOST   608     printed  Apr 09, 2024@20:50:28                                                                                                                                                                                                     Page 2

PSXBPOST  ;BIR/HTW-Post Initialization Routine;8/15/95 [ 08/25/95  3:28 PM ]

 +1       ;;1.0;CONSOLIDATED MAIL OUTPATIENT PHARMACY;**2**;10 May 95

 +2        NEW I,NAME,DIE,DR,DA

REM        FOR I="PSX ARCHIVE","PSX ARCHIVE PURGE","PSX ARCHIVE RETRIEVE","PSX ARCHIVE SAVE"

               Begin DoDot:1

 +1                SET DA=$ORDER(^DIC(19,"B",I,0))

                   if 'DA

                       QUIT 

 +2                SET DIK="^DIC(19,"

                   DO ^DIK

               End DoDot:1

 +3        KILL DIK,DA

 +4        FOR I="PSXB ARCHIVE","PSXB ARCHIVE PURGE","PSXB ARCHIVE RETRIEVE","PSXB ARCHIVE SAVE"

               Begin DoDot:1

 +5                SET NAME="PSX"_$PIECE(I,"B",2)

                   SET DA=$ORDER(^DIC(19,"B",I,0))

                   if 'DA

                       QUIT 

 +6                SET DIE="^DIC(19,"

                   SET DR=".01////"_NAME

 +7                DO ^DIE

 +8                WRITE !,"Option ",I," renamed ",NAME

               End DoDot:1

 +9        WRITE !!,"Installation complete!"

 +10       KILL DA,NAME,DIE,DR,I

 +11       QUIT