RMPG6 ;DDC/KAW-ROES PATCH RMPF*2.0*9-AHS [ 01/28/98 9:30 AM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**9**;1/21/98
W @IOF,!,"ROES PATCH: RMPF*2.0*9"
W !!,"This patch will inactivate old Custom Hearing Aid models and components"
W !,"and add new models, makes and components for the Custom Hearing Aid"
W !,"contracts that take affect on February 1, 1998. Only ROES users must be"
W !,"off of the system while running the patch. These contract changes will"
W !,"take affect on February 1, 1998, at the DDC, so this patch should"
W !,"be installed between COB 1/30/98 and the morning of 2/2/98 at your station."
W !!,"The only files affected are:"
W !!?10,"791811 - REMOTE INVENTORY PRODUCT"
W !?10,"791811.2 - HEARING AID COMPONENTS"
W !?10,"791811.3 - BATTERY FILE",!
W !!,"Inactivating old models and components"
S RMPFX=0
F S RMPFX=$O(^RMPF(791811,RMPFX)) Q:'RMPFX D
.S X=$P($G(^RMPF(791811,RMPFX,0)),U,3) Q:'X S NM=$P(^(0),U,1)
.Q:'$D(^RMPF(791811.1,X,0)) Q:$P(^(0),U,1)'="CUSTOM HEARING AIDS"
.S DIE="^RMPF(791811,",DA=RMPFX,DR="999////1" D ^DIE W "."
.K ^RMPF(791811,RMPFX,101),^(102)
D ^RMPG6A
W !!,"Update Complete"
END K BP,BT,BX,CA,%,CD,CP,CS,CX,DLAYGO,DQ,D0,DI,DA,DR,DIC,DIE,IX,IY,IZ,MD,MP,NM,ST,SX,X,Y,RMPFX Q
SET1 I '$D(^RMPF(791811,MP,101,0)) S ^RMPF(791811,MP,101,0)="^791811.0101PA"
Q:$D(^RMPF(791811,MP,101,"B",CX))
S DIC="^RMPF(791811,"_MP_",101,",X=CX,DIC(0)="L",DLAYGO=791811
S DIC("DR")=".02////"_CS,DA(1)=MP K DD,DO D FILE^DICN K DIC
I Y=-1 W !!,CP," not added."
Q
SET2 I '$D(^RMPF(791811,MP,102,0)) S ^RMPF(791811,MP,102,0)="^791811.0102PA"
Q:$D(^RMPF(791811,MP,102,"B",BP))
S DIC="^RMPF(791811,"_MP_",102,",X=BP,DIC(0)="L",DLAYGO=791811
S DA(1)=MP K DD,DO D FILE^DICN K DIC
I Y=-1 W !!,BP," not added."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPG6 1799 printed Apr 09, 2024@21:39:21 Page 2
RMPG6 ;DDC/KAW-ROES PATCH RMPF*2.0*9-AHS [ 01/28/98 9:30 AM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**9**;1/21/98
+2 WRITE @IOF,!,"ROES PATCH: RMPF*2.0*9"
+3 WRITE !!,"This patch will inactivate old Custom Hearing Aid models and components"
+4 WRITE !,"and add new models, makes and components for the Custom Hearing Aid"
+5 WRITE !,"contracts that take affect on February 1, 1998. Only ROES users must be"
+6 WRITE !,"off of the system while running the patch. These contract changes will"
+7 WRITE !,"take affect on February 1, 1998, at the DDC, so this patch should"
+8 WRITE !,"be installed between COB 1/30/98 and the morning of 2/2/98 at your station."
+9 WRITE !!,"The only files affected are:"
+10 WRITE !!?10,"791811 - REMOTE INVENTORY PRODUCT"
+11 WRITE !?10,"791811.2 - HEARING AID COMPONENTS"
+12 WRITE !?10,"791811.3 - BATTERY FILE",!
+13 WRITE !!,"Inactivating old models and components"
+14 SET RMPFX=0
+15 FOR
SET RMPFX=$ORDER(^RMPF(791811,RMPFX))
if 'RMPFX
QUIT
Begin DoDot:1
+16 SET X=$PIECE($GET(^RMPF(791811,RMPFX,0)),U,3)
if 'X
QUIT
SET NM=$PIECE(^(0),U,1)
+17 if '$DATA(^RMPF(791811.1,X,0))
QUIT
if $PIECE(^(0),U,1)'="CUSTOM HEARING AIDS"
QUIT
+18 SET DIE="^RMPF(791811,"
SET DA=RMPFX
SET DR="999////1"
DO ^DIE
WRITE "."
+19 KILL ^RMPF(791811,RMPFX,101),^(102)
End DoDot:1
+20 DO ^RMPG6A
+21 WRITE !!,"Update Complete"
END KILL BP,BT,BX,CA,%,CD,CP,CS,CX,DLAYGO,DQ,D0,DI,DA,DR,DIC,DIE,IX,IY,IZ,MD,MP,NM,ST,SX,X,Y,RMPFX
QUIT
SET1 IF '$DATA(^RMPF(791811,MP,101,0))
SET ^RMPF(791811,MP,101,0)="^791811.0101PA"
+1 if $DATA(^RMPF(791811,MP,101,"B",CX))
QUIT
+2 SET DIC="^RMPF(791811,"_MP_",101,"
SET X=CX
SET DIC(0)="L"
SET DLAYGO=791811
+3 SET DIC("DR")=".02////"_CS
SET DA(1)=MP
KILL DD,DO
DO FILE^DICN
KILL DIC
+4 IF Y=-1
WRITE !!,CP," not added."
+5 QUIT
SET2 IF '$DATA(^RMPF(791811,MP,102,0))
SET ^RMPF(791811,MP,102,0)="^791811.0102PA"
+1 if $DATA(^RMPF(791811,MP,102,"B",BP))
QUIT
+2 SET DIC="^RMPF(791811,"_MP_",102,"
SET X=BP
SET DIC(0)="L"
SET DLAYGO=791811
+3 SET DA(1)=MP
KILL DD,DO
DO FILE^DICN
KILL DIC
+4 IF Y=-1
WRITE !!,BP," not added."
+5 QUIT
