RMPRPIUJ ;HINES OIFO/ODJ - CONVERT OLD PIP TO NEW PIP ;3/8/05 11:47
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
; DBIA #10090 - Read Access to entire file #4.
Q
;
;***** LOCN - Convert Locations in 661.3 to new 661.5 file
; A GENERIC location will be created as a scratch
; area.
; Duplicate location names will not be allowed.
; Build map file in ^TMP($J,"LOCN" which maps old
; to new location iens.
;
LOCN N RMPRSTN,RMPRLCN,RMPRTOD,RMPRL,RMPRCNT,RMPRREC,RMPRERR,RMPR5,RMPRI
N X,Y,DA
I '$D(IO("Q")) D
. W !,"Creating Locations in file 661.5 "
. Q
K ^TMP($J,"LOCN")
D NOW^%DTC
S RMPRTOD=X ; today's date
;
; Init RMPR5
S RMPR5("STATUS")="A" ;active status
S RMPR5("STATUS DATE")=RMPRTOD ;status date is today's date
S RMPR5("USER")=""
S RMPRDUZ=$$GETUSR^RMPRPIU0(DUZ)
I $G(DUZ)'="",(RMPRDUZ'="") S RMPR5("USER")=DUZ
;
; Loop on Locations 661.3
S RMPRL=0
LOC1 S RMPRL=$O(^RMPR(661.3,RMPRL))
I '+RMPRL G LOCNX ;exit if no more Locations
I '$D(IO("Q")) D
. W:$X=79 ! W "."
. Q
S RMPRREC=$G(^RMPR(661.3,RMPRL,0))
K RMPR5("IEN")
S RMPR5("STATION")=$P(RMPRREC,"^",3) ; Station
I RMPR5("STATION")="" G LOC1 ;ignore if null Station
I '$D(^DIC(4,RMPR5("STATION"),0)) G LOC1 ;ignore if bad ptr.
;
; Create GENERIC stock location if 1st location @ Station
I '$D(^RMPR(661.5,"XSL",RMPR5("STATION"))) D
. S RMPR5("NAME")="GENERIC"
. S RMPR5("ADDRESS")="GENERIC STOCK LOCATION (SYSTEM)"
. S RMPRERR=$$CRE^RMPRPIX5(.RMPR5)
. K RMPR5("IEN")
. Q
;
; Create Location
S RMPR5("NAME")=$P(RMPRREC,"^",1)
S RMPR5("ADDRESS")=$P(RMPRREC,"^",2)
;
; Check for duplicate location name and force to be unique
I $D(^RMPR(661.5,"XSL",RMPR5("STATION"),RMPR5("NAME"))) D
. S RMPRCNT=2
. F D Q:'$D(^RMPR(661.5,"XSL",RMPR5("STATION"),RMPR5("NAME")))
.. S RMPR5("NAME")=RMPR5("NAME")_" ("_RMPRCNT_")"
.. S RMPRCNT=1+RMPRCNT
.. Q
. Q
;
; Create Location in new 661.5 file
S RMPRERR=$$CRE^RMPRPIX5(.RMPR5)
S ^TMP($J,"LOCN",RMPRL)=RMPR5("IEN") ; map old to new Locn. ien
;
G LOC1 ;next Location
;
;exit
LOCNX Q
;
UNIT ;update UNIT of issue #661.7
N RI,RMDA,RMU,RHC,RIT,RST,R11DA,R11
F RI=0:0 S RI=$O(^RMPR(661.7,RI)) Q:RI'>0 S RMDA=$G(^RMPR(661.7,RI,0)) D
.S RMU=$P(RMDA,U,9)
.Q:$G(RMU)
.S RHC=$P(RMDA,U,1),RIT=$P(RMDA,U,4),RST=$P(RMDA,U,5)
.S R11=$O(^RMPR(661.11,"ASHI",RST,RHC,RIT,0))
.Q:'$G(R11)
.Q:'$D(^RMPR(661.11,R11,0))
.S R11DA=$G(^RMPR(661.11,R11,0)),RMU=$P(R11DA,U,6)
.Q:'$G(RMU)
.S $P(^RMPR(661.7,RI,0),U,9)=RMU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIUJ 2609 printed Sep 23, 2025@20:12:39 Page 2
RMPRPIUJ ;HINES OIFO/ODJ - CONVERT OLD PIP TO NEW PIP ;3/8/05 11:47
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ; DBIA #10090 - Read Access to entire file #4.
+3 QUIT
+4 ;
+5 ;***** LOCN - Convert Locations in 661.3 to new 661.5 file
+6 ; A GENERIC location will be created as a scratch
+7 ; area.
+8 ; Duplicate location names will not be allowed.
+9 ; Build map file in ^TMP($J,"LOCN" which maps old
+10 ; to new location iens.
+11 ;
LOCN NEW RMPRSTN,RMPRLCN,RMPRTOD,RMPRL,RMPRCNT,RMPRREC,RMPRERR,RMPR5,RMPRI
+1 NEW X,Y,DA
+2 IF '$DATA(IO("Q"))
Begin DoDot:1
+3 WRITE !,"Creating Locations in file 661.5 "
+4 QUIT
End DoDot:1
+5 KILL ^TMP($JOB,"LOCN")
+6 DO NOW^%DTC
+7 ; today's date
SET RMPRTOD=X
+8 ;
+9 ; Init RMPR5
+10 ;active status
SET RMPR5("STATUS")="A"
+11 ;status date is today's date
SET RMPR5("STATUS DATE")=RMPRTOD
+12 SET RMPR5("USER")=""
+13 SET RMPRDUZ=$$GETUSR^RMPRPIU0(DUZ)
+14 IF $GET(DUZ)'=""
IF (RMPRDUZ'="")
SET RMPR5("USER")=DUZ
+15 ;
+16 ; Loop on Locations 661.3
+17 SET RMPRL=0
LOC1 SET RMPRL=$ORDER(^RMPR(661.3,RMPRL))
+1 ;exit if no more Locations
IF '+RMPRL
GOTO LOCNX
+2 IF '$DATA(IO("Q"))
Begin DoDot:1
+3 if $X=79
WRITE !
WRITE "."
+4 QUIT
End DoDot:1
+5 SET RMPRREC=$GET(^RMPR(661.3,RMPRL,0))
+6 KILL RMPR5("IEN")
+7 ; Station
SET RMPR5("STATION")=$PIECE(RMPRREC,"^",3)
+8 ;ignore if null Station
IF RMPR5("STATION")=""
GOTO LOC1
+9 ;ignore if bad ptr.
IF '$DATA(^DIC(4,RMPR5("STATION"),0))
GOTO LOC1
+10 ;
+11 ; Create GENERIC stock location if 1st location @ Station
+12 IF '$DATA(^RMPR(661.5,"XSL",RMPR5("STATION")))
Begin DoDot:1
+13 SET RMPR5("NAME")="GENERIC"
+14 SET RMPR5("ADDRESS")="GENERIC STOCK LOCATION (SYSTEM)"
+15 SET RMPRERR=$$CRE^RMPRPIX5(.RMPR5)
+16 KILL RMPR5("IEN")
+17 QUIT
End DoDot:1
+18 ;
+19 ; Create Location
+20 SET RMPR5("NAME")=$PIECE(RMPRREC,"^",1)
+21 SET RMPR5("ADDRESS")=$PIECE(RMPRREC,"^",2)
+22 ;
+23 ; Check for duplicate location name and force to be unique
+24 IF $DATA(^RMPR(661.5,"XSL",RMPR5("STATION"),RMPR5("NAME")))
Begin DoDot:1
+25 SET RMPRCNT=2
+26 FOR
Begin DoDot:2
+27 SET RMPR5("NAME")=RMPR5("NAME")_" ("_RMPRCNT_")"
+28 SET RMPRCNT=1+RMPRCNT
+29 QUIT
End DoDot:2
if '$DATA(^RMPR(661.5,"XSL",RMPR5("STATION"),RMPR5("NAME")))
QUIT
+30 QUIT
End DoDot:1
+31 ;
+32 ; Create Location in new 661.5 file
+33 SET RMPRERR=$$CRE^RMPRPIX5(.RMPR5)
+34 ; map old to new Locn. ien
SET ^TMP($JOB,"LOCN",RMPRL)=RMPR5("IEN")
+35 ;
+36 ;next Location
GOTO LOC1
+37 ;
+38 ;exit
LOCNX QUIT
+1 ;
UNIT ;update UNIT of issue #661.7
+1 NEW RI,RMDA,RMU,RHC,RIT,RST,R11DA,R11
+2 FOR RI=0:0
SET RI=$ORDER(^RMPR(661.7,RI))
if RI'>0
QUIT
SET RMDA=$GET(^RMPR(661.7,RI,0))
Begin DoDot:1
+3 SET RMU=$PIECE(RMDA,U,9)
+4 if $GET(RMU)
QUIT
+5 SET RHC=$PIECE(RMDA,U,1)
SET RIT=$PIECE(RMDA,U,4)
SET RST=$PIECE(RMDA,U,5)
+6 SET R11=$ORDER(^RMPR(661.11,"ASHI",RST,RHC,RIT,0))
+7 if '$GET(R11)
QUIT
+8 if '$DATA(^RMPR(661.11,R11,0))
QUIT
+9 SET R11DA=$GET(^RMPR(661.11,R11,0))
SET RMU=$PIECE(R11DA,U,6)
+10 if '$GET(RMU)
QUIT
+11 SET $PIECE(^RMPR(661.7,RI,0),U,9)=RMU
End DoDot:1
+12 QUIT
