- 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 Feb 19, 2025@00:03:17 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