RMPRPIXZ ;HINCIO/ODJ - MISC. ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
; Some miscellaneous routines to be used for testing only
; NOT FOR GENERAL USE
;
;
; Clear down new PIP files
; Only use if need to re-run the old to new PIP file conversion
; utility in RMPRPIUG
KILL N FIL,S,P62,I,P60
;
; Restore pointers to 661.2 in file 660
S I=0
F S I=$O(^RMPR(661.63,I)) Q:'+I D
. S S=^RMPR(661.63,I,0)
. S P62=$P(S,"^",3)
. S P60=$P(S,"^",2)
. S $P(^RMPR(660,P60,1),"^",5)=P62
. Q
;
; Clear down new files
F FIL=661.11,661.4,661.41,661.5,661.6,661.63,661.69,661.7,661.9 D
. S S=^RMPR(FIL,0)
. S $P(S,"^",3)=0,$P(S,"^",4)=0
. K ^RMPR(FIL)
. S ^RMPR(FIL,0)=S
. Q
Q
;
; Make all Locations start with 'A'
ALOC N NM,IEN,RMPR,RMPRE,FIL
F FIL=661.3,661.5 D
. S IEN=0
. F S IEN=$O(^RMPR(FIL,IEN)) Q:'+IEN D
.. S NM=$P(^RMPR(FIL,IEN,0),"^",1)
.. W !,NM
.. K RMPR
.. S RMPR(FIL,IEN_",",.01)="A"_NM
.. D FILE^DIE("","RMPR","RMPRE")
.. Q
. Q
Q
;
; Get rid of 1st char.
REMA N NM,IEN,RMPR,RMPRE,FIL
F FIL=661.3,661.5 D
. S IEN=0
. F S IEN=$O(^RMPR(FIL,IEN)) Q:'+IEN D
.. S NM=$P(^RMPR(FIL,IEN,0),"^",1)
.. W !,NM
.. K RMPR
.. S RMPR(FIL,IEN_",",.01)=$E(NM,2,$L(NM))
.. D FILE^DIE("","RMPR","RMPRE")
.. Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIXZ 1318 printed Dec 13, 2024@02:36:49 Page 2
RMPRPIXZ ;HINCIO/ODJ - MISC. ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ; Some miscellaneous routines to be used for testing only
+5 ; NOT FOR GENERAL USE
+6 ;
+7 ;
+8 ; Clear down new PIP files
+9 ; Only use if need to re-run the old to new PIP file conversion
+10 ; utility in RMPRPIUG
KILL NEW FIL,S,P62,I,P60
+1 ;
+2 ; Restore pointers to 661.2 in file 660
+3 SET I=0
+4 FOR
SET I=$ORDER(^RMPR(661.63,I))
if '+I
QUIT
Begin DoDot:1
+5 SET S=^RMPR(661.63,I,0)
+6 SET P62=$PIECE(S,"^",3)
+7 SET P60=$PIECE(S,"^",2)
+8 SET $PIECE(^RMPR(660,P60,1),"^",5)=P62
+9 QUIT
End DoDot:1
+10 ;
+11 ; Clear down new files
+12 FOR FIL=661.11,661.4,661.41,661.5,661.6,661.63,661.69,661.7,661.9
Begin DoDot:1
+13 SET S=^RMPR(FIL,0)
+14 SET $PIECE(S,"^",3)=0
SET $PIECE(S,"^",4)=0
+15 KILL ^RMPR(FIL)
+16 SET ^RMPR(FIL,0)=S
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
+20 ; Make all Locations start with 'A'
ALOC NEW NM,IEN,RMPR,RMPRE,FIL
+1 FOR FIL=661.3,661.5
Begin DoDot:1
+2 SET IEN=0
+3 FOR
SET IEN=$ORDER(^RMPR(FIL,IEN))
if '+IEN
QUIT
Begin DoDot:2
+4 SET NM=$PIECE(^RMPR(FIL,IEN,0),"^",1)
+5 WRITE !,NM
+6 KILL RMPR
+7 SET RMPR(FIL,IEN_",",.01)="A"_NM
+8 DO FILE^DIE("","RMPR","RMPRE")
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
+13 ; Get rid of 1st char.
REMA NEW NM,IEN,RMPR,RMPRE,FIL
+1 FOR FIL=661.3,661.5
Begin DoDot:1
+2 SET IEN=0
+3 FOR
SET IEN=$ORDER(^RMPR(FIL,IEN))
if '+IEN
QUIT
Begin DoDot:2
+4 SET NM=$PIECE(^RMPR(FIL,IEN,0),"^",1)
+5 WRITE !,NM
+6 KILL RMPR
+7 SET RMPR(FIL,IEN_",",.01)=$EXTRACT(NM,2,$LENGTH(NM))
+8 DO FILE^DIE("","RMPR","RMPRE")
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
