RMPRPIUH ;HINCIO/ODJ - CONVERT OLD PIP TO NEW PIP ;3/8/05 11:45
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
; DBIA #10090 - Read Access to entire file #4.
Q
;
;***** CONV - Convert old PIP files to the new design
; continued from RMPRPIUG
; Create issue transactions
;
; Convert patient issues in 660 file
;
; Start loop at 1st date in 661.2
CONV N RMPRDT,RMPRIEN,RMPRR60,RMPR62P,RMPRREC,RMPR6,RMPR11,RMPR62R,RMPRITM
N RMPR63P,RMPR63R,RMPR5,RMPRHIEN,RMPRS,RMPRERR,RMPRTIME,RMPR60
I '$D(IO("Q")) D
. W !,"Creating patient issue transactions - file 661.6 "
. Q
K ^TMP($J,"ISS")
S RMPRDT=$O(^RMPR(661.2,"B",""))
I RMPRDT'="" S RMPRDT=RMPRDT-1
;
; Loop on ENTRY DATE ('B') x-ref in 660 file
CONV1 S RMPRDT=$O(^RMPR(660,"B",RMPRDT))
I '$D(IO("Q")) D
. W:$X=79 ! W "."
. Q
I RMPRDT="" G CONVX
S RMPRIEN=0
CONV2 S RMPRIEN=$O(^RMPR(660,"B",RMPRDT,RMPRIEN))
I '+RMPRIEN G CONV1
;
; read 660 recs and set up arrays
K RMPR60
S RMPR60("IEN")=RMPRIEN
S RMPRR60=$G(^RMPR(660,RMPRIEN,1))
S RMPR62P=$P(RMPRR60,"^",5) ;pointer to 661.2
I RMPR62P="" G CONV2 ;ignore if null ptr.
I '$D(^RMPR(661.2,RMPR62P)) G CONV2 ;ignore if invalid ptr.
S RMPRREC=$G(^RMPR(660,RMPRIEN,0))
K RMPR6
I RMPRDT'=$P(RMPRREC,"^",1) G CONV2 ;bad 'B' x-ref
S RMPR6("QUANTITY")=+$P(RMPRREC,"^",7)
I RMPR6("QUANTITY")=0 G CONV2 ;ignore if 0 qty
S RMPR6("VALUE")=$P(RMPRREC,"^",16)
S RMPR6("VENDOR")=$P(RMPRREC,"^",9)
I RMPR6("VENDOR")="" G CONV2 ;ignore if null vendor
S RMPR6("USER")=$P(RMPRREC,"^",27)
;
; Get HCPCS and HCPCS Item using file 661.2
S RMPR62R=$G(^RMPR(661.2,RMPR62P,0))
S RMPR60("661.2PTR")=RMPR62P
K RMPR11
S RMPR11("ITEM MASTER IEN")=$P(RMPRREC,"^",6)
S RMPR11("STATION")=$P(RMPR62R,"^",15)
I RMPR11("STATION")="" G CONV2 ;ignore if null station
I '$D(^DIC(4,RMPR11("STATION"),0)) G CONV2 ;ignore if bad ptr
S RMPR11("HCPCS")=$P($P(RMPR62R,"^",9),"-",1) ;HCPCS Code
I RMPR11("HCPCS")="" G CONV2 ;ignore if null HCPCS
S RMPRHIEN=$P(RMPR62R,"^",4) ;HCPCS ptr
I RMPRHIEN="" G CONV2 ;ignore if null HCPCS ptr
S RMPRITM=$P($P(RMPR62R,"^",9),"-",2) ;Item ptr
I RMPRITM="" G CONV2 ;ignore if null item
S RMPR11("SOURCE")=$P(RMPR62R,"^",3)
I RMPR11("SOURCE")'="V" S RMPR11("SOURCE")="C"
S RMPR11("UNIT")=$P(RMPR62R,"^",5)
D GETITM(.RMPR11,RMPRHIEN,RMPRITM)
;
; Get Location
K RMPR5
S RMPR63P=$P(RMPR62R,"^",16) ;ptr to location 661.3 file
S RMPR5("STATION")=RMPR11("STATION")
S RMPRERR=$$GETLCN(RMPR63P,.RMPR5) ; get location
I RMPRERR G CONV2 ;ignore if bad location
;
; If get here then enough to create a stock issue to patient
; transaction...
S RMPR6("DATE&TIME")=""
F D Q:RMPR6("DATE&TIME")'=""
. D NOW^%DTC
. S RMPRTIME=RMPRDT_"."_$P(%,".",2)
. I $D(^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME)) H (1+$R(3)) Q
. L +^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME):0 E H (1+$R(3)) Q
. S RMPR6("DATE&TIME")=RMPRTIME
. Q
S RMPR6("LOCATION")=RMPR5("IEN")
S RMPRS=$G(^TMP($J,"ISS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("LOCATION"),RMPR6("VENDOR")))
S $P(RMPRS,"^",1)=RMPR6("QUANTITY")+$P(RMPRS,"^",1)
S $P(RMPRS,"^",2)=RMPR6("VALUE")+$P(RMPRS,"^",2)
S ^TMP($J,"ISS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("LOCATION"),RMPR6("VENDOR"))=RMPRS
S RMPR6("SEQUENCE")=1
S RMPR6("COMMENT")=""
S RMPR6("TRAN TYPE")=3
S RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
S $P(RMPRR60,"^",5)=RMPR6("IEN")
S ^RMPR(660,RMPRIEN,1)=RMPRR60
L -^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPR6("DATE&TIME"))
;
; Create 661.63 Patient Issue transaction record
S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11)
;
; Next rec
G CONV2
;
; Exit
CONVX Q
;
; Get a Location from the pointer to file 661.3
; RMPRPIUJ should have been already run to set up the new locations
; file 661.5 and the temp map file.
; If can't get a valid location default to the GENERIC location
GETLCN(RMPR63P,RMPR5) ;
N RMPRERR
S RMPRERR=0
I RMPR63P="" S RMPRERR=1 G GETLCNX
I '$D(^RMPR(661.5,"XSL",RMPR5("STATION"))) S RMPRERR=2 G GETLCNX
;
; if old (661.3) pointer mapped to new (661.5) pointer use it
I $D(^TMP($J,"LOCN",RMPR63P)) D G GETLCNX
. S RMPR5("IEN")=^TMP($J,"LOCN",RMPR63P)
. Q
;
; else use the 661.5 pointer for GENERIC location
E D
. S RMPR5("IEN")=$O(^RMPR(661.5,"XSL",RMPR5("STATION"),"GENERIC",""))
. Q
GETLCNX Q RMPRERR
;
; Get HCPCS Item
; Commercial items should have already been set up by running
; RMPRPIUI
; VA items and those items in 661.2 which are no longer in the 661.3
; file will be created together with a map of old to new iens.
GETITM(RMPR11,RMPRHIEN,RMPRITM) ;
N RMPRI,RMPRS,RMPRERR,RMPRIM,RMPR11U,RMPRGOT
S RMPR11("ITEM MASTER IEN")=$G(RMPR11("ITEM MASTER IEN"))
S RMPRIM=RMPR11("ITEM MASTER IEN")
S:RMPRIM="" RMPRIM="*"
;
; If item has new number from previous update then use the temp map
I $D(^TMP($J,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM)) D G GETITMX
. S RMPRS=^TMP($J,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM)
. S RMPR11("ITEM")=$P(RMPRS,"^",3)
. Q
;
; If item number not already in use then can use it to create a new
; item in file 661.11
I '$D(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPRITM)) S RMPR11("ITEM")=RMPRITM G GETITM1
;
; Ensure not duplicating Item number for different source
S RMPRGOT=0
S RMPRI=$O(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPRITM,""))
S RMPRS=^RMPR(661.11,RMPRI,0)
I $P(RMPRS,"^",5)=RMPR11("SOURCE") D
. I $P(RMPRS,"^",8)=RMPR11("ITEM MASTER IEN") S RMPRGOT=1 Q
. I $P(RMPRS,"^",8)="" D
.. K RMPR11U
.. S RMPR11U("IEN")=RMPRI
.. S RMPR11U("ITEM MASTER IEN")=RMPR11("ITEM MASTER IEN")
.. S RMPRERR=$$UPD^RMPRPIX1(.RMPR11U)
.. S RMPRGOT=1
.. Q
. Q
I RMPRGOT S RMPR11("ITEM")=RMPRITM G GETITMX
S RMPR11("ITEM")="" ; ensure new item will be created
GETITM1 S RMPRS=$G(^RMPR(661.1,RMPRHIEN,3,RMPRITM,0))
S RMPR11("DESCRIPTION")=$P(RMPRS,"^",1)
S:RMPR11("DESCRIPTION")="" RMPR11("DESCRIPTION")="NO DESCRIPTION"
S RMPRERR=$$CRE^RMPRPIX1(.RMPR11)
;
; map new HCPCS Item in 661.11 to old iens in 661.1
S RMPRS=""
S $P(RMPRS,"^",1)=RMPR11("STATION")
S $P(RMPRS,"^",2)=RMPR11("HCPCS")
S $P(RMPRS,"^",3)=RMPR11("ITEM")
S $P(RMPRS,"^",4)=RMPR11("IEN")
S ^TMP($J,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM)=RMPRS
GETITMX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIUH 6435 printed Sep 23, 2025@20:12:37 Page 2
RMPRPIUH ;HINCIO/ODJ - CONVERT OLD PIP TO NEW PIP ;3/8/05 11:45
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ; DBIA #10090 - Read Access to entire file #4.
+3 QUIT
+4 ;
+5 ;***** CONV - Convert old PIP files to the new design
+6 ; continued from RMPRPIUG
+7 ; Create issue transactions
+8 ;
+9 ; Convert patient issues in 660 file
+10 ;
+11 ; Start loop at 1st date in 661.2
CONV NEW RMPRDT,RMPRIEN,RMPRR60,RMPR62P,RMPRREC,RMPR6,RMPR11,RMPR62R,RMPRITM
+1 NEW RMPR63P,RMPR63R,RMPR5,RMPRHIEN,RMPRS,RMPRERR,RMPRTIME,RMPR60
+2 IF '$DATA(IO("Q"))
Begin DoDot:1
+3 WRITE !,"Creating patient issue transactions - file 661.6 "
+4 QUIT
End DoDot:1
+5 KILL ^TMP($JOB,"ISS")
+6 SET RMPRDT=$ORDER(^RMPR(661.2,"B",""))
+7 IF RMPRDT'=""
SET RMPRDT=RMPRDT-1
+8 ;
+9 ; Loop on ENTRY DATE ('B') x-ref in 660 file
CONV1 SET RMPRDT=$ORDER(^RMPR(660,"B",RMPRDT))
+1 IF '$DATA(IO("Q"))
Begin DoDot:1
+2 if $X=79
WRITE !
WRITE "."
+3 QUIT
End DoDot:1
+4 IF RMPRDT=""
GOTO CONVX
+5 SET RMPRIEN=0
CONV2 SET RMPRIEN=$ORDER(^RMPR(660,"B",RMPRDT,RMPRIEN))
+1 IF '+RMPRIEN
GOTO CONV1
+2 ;
+3 ; read 660 recs and set up arrays
+4 KILL RMPR60
+5 SET RMPR60("IEN")=RMPRIEN
+6 SET RMPRR60=$GET(^RMPR(660,RMPRIEN,1))
+7 ;pointer to 661.2
SET RMPR62P=$PIECE(RMPRR60,"^",5)
+8 ;ignore if null ptr.
IF RMPR62P=""
GOTO CONV2
+9 ;ignore if invalid ptr.
IF '$DATA(^RMPR(661.2,RMPR62P))
GOTO CONV2
+10 SET RMPRREC=$GET(^RMPR(660,RMPRIEN,0))
+11 KILL RMPR6
+12 ;bad 'B' x-ref
IF RMPRDT'=$PIECE(RMPRREC,"^",1)
GOTO CONV2
+13 SET RMPR6("QUANTITY")=+$PIECE(RMPRREC,"^",7)
+14 ;ignore if 0 qty
IF RMPR6("QUANTITY")=0
GOTO CONV2
+15 SET RMPR6("VALUE")=$PIECE(RMPRREC,"^",16)
+16 SET RMPR6("VENDOR")=$PIECE(RMPRREC,"^",9)
+17 ;ignore if null vendor
IF RMPR6("VENDOR")=""
GOTO CONV2
+18 SET RMPR6("USER")=$PIECE(RMPRREC,"^",27)
+19 ;
+20 ; Get HCPCS and HCPCS Item using file 661.2
+21 SET RMPR62R=$GET(^RMPR(661.2,RMPR62P,0))
+22 SET RMPR60("661.2PTR")=RMPR62P
+23 KILL RMPR11
+24 SET RMPR11("ITEM MASTER IEN")=$PIECE(RMPRREC,"^",6)
+25 SET RMPR11("STATION")=$PIECE(RMPR62R,"^",15)
+26 ;ignore if null station
IF RMPR11("STATION")=""
GOTO CONV2
+27 ;ignore if bad ptr
IF '$DATA(^DIC(4,RMPR11("STATION"),0))
GOTO CONV2
+28 ;HCPCS Code
SET RMPR11("HCPCS")=$PIECE($PIECE(RMPR62R,"^",9),"-",1)
+29 ;ignore if null HCPCS
IF RMPR11("HCPCS")=""
GOTO CONV2
+30 ;HCPCS ptr
SET RMPRHIEN=$PIECE(RMPR62R,"^",4)
+31 ;ignore if null HCPCS ptr
IF RMPRHIEN=""
GOTO CONV2
+32 ;Item ptr
SET RMPRITM=$PIECE($PIECE(RMPR62R,"^",9),"-",2)
+33 ;ignore if null item
IF RMPRITM=""
GOTO CONV2
+34 SET RMPR11("SOURCE")=$PIECE(RMPR62R,"^",3)
+35 IF RMPR11("SOURCE")'="V"
SET RMPR11("SOURCE")="C"
+36 SET RMPR11("UNIT")=$PIECE(RMPR62R,"^",5)
+37 DO GETITM(.RMPR11,RMPRHIEN,RMPRITM)
+38 ;
+39 ; Get Location
+40 KILL RMPR5
+41 ;ptr to location 661.3 file
SET RMPR63P=$PIECE(RMPR62R,"^",16)
+42 SET RMPR5("STATION")=RMPR11("STATION")
+43 ; get location
SET RMPRERR=$$GETLCN(RMPR63P,.RMPR5)
+44 ;ignore if bad location
IF RMPRERR
GOTO CONV2
+45 ;
+46 ; If get here then enough to create a stock issue to patient
+47 ; transaction...
+48 SET RMPR6("DATE&TIME")=""
+49 FOR
Begin DoDot:1
+50 DO NOW^%DTC
+51 SET RMPRTIME=RMPRDT_"."_$PIECE(%,".",2)
+52 IF $DATA(^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME))
HANG (1+$RANDOM(3))
QUIT
+53 LOCK +^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME):0
IF '$TEST
HANG (1+$RANDOM(3))
QUIT
+54 SET RMPR6("DATE&TIME")=RMPRTIME
+55 QUIT
End DoDot:1
if RMPR6("DATE&TIME")'=""
QUIT
+56 SET RMPR6("LOCATION")=RMPR5("IEN")
+57 SET RMPRS=$GET(^TMP($JOB,"ISS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("LOCATION"),RMPR6("VENDOR")))
+58 SET $PIECE(RMPRS,"^",1)=RMPR6("QUANTITY")+$PIECE(RMPRS,"^",1)
+59 SET $PIECE(RMPRS,"^",2)=RMPR6("VALUE")+$PIECE(RMPRS,"^",2)
+60 SET ^TMP($JOB,"ISS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("LOCATION"),RMPR6("VENDOR"))=RMPRS
+61 SET RMPR6("SEQUENCE")=1
+62 SET RMPR6("COMMENT")=""
+63 SET RMPR6("TRAN TYPE")=3
+64 SET RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
+65 SET $PIECE(RMPRR60,"^",5)=RMPR6("IEN")
+66 SET ^RMPR(660,RMPRIEN,1)=RMPRR60
+67 LOCK -^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPR6("DATE&TIME"))
+68 ;
+69 ; Create 661.63 Patient Issue transaction record
+70 SET RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11)
+71 ;
+72 ; Next rec
+73 GOTO CONV2
+74 ;
+75 ; Exit
CONVX QUIT
+1 ;
+2 ; Get a Location from the pointer to file 661.3
+3 ; RMPRPIUJ should have been already run to set up the new locations
+4 ; file 661.5 and the temp map file.
+5 ; If can't get a valid location default to the GENERIC location
GETLCN(RMPR63P,RMPR5) ;
+1 NEW RMPRERR
+2 SET RMPRERR=0
+3 IF RMPR63P=""
SET RMPRERR=1
GOTO GETLCNX
+4 IF '$DATA(^RMPR(661.5,"XSL",RMPR5("STATION")))
SET RMPRERR=2
GOTO GETLCNX
+5 ;
+6 ; if old (661.3) pointer mapped to new (661.5) pointer use it
+7 IF $DATA(^TMP($JOB,"LOCN",RMPR63P))
Begin DoDot:1
+8 SET RMPR5("IEN")=^TMP($JOB,"LOCN",RMPR63P)
+9 QUIT
End DoDot:1
GOTO GETLCNX
+10 ;
+11 ; else use the 661.5 pointer for GENERIC location
+12 IF '$TEST
Begin DoDot:1
+13 SET RMPR5("IEN")=$ORDER(^RMPR(661.5,"XSL",RMPR5("STATION"),"GENERIC",""))
+14 QUIT
End DoDot:1
GETLCNX QUIT RMPRERR
+1 ;
+2 ; Get HCPCS Item
+3 ; Commercial items should have already been set up by running
+4 ; RMPRPIUI
+5 ; VA items and those items in 661.2 which are no longer in the 661.3
+6 ; file will be created together with a map of old to new iens.
GETITM(RMPR11,RMPRHIEN,RMPRITM) ;
+1 NEW RMPRI,RMPRS,RMPRERR,RMPRIM,RMPR11U,RMPRGOT
+2 SET RMPR11("ITEM MASTER IEN")=$GET(RMPR11("ITEM MASTER IEN"))
+3 SET RMPRIM=RMPR11("ITEM MASTER IEN")
+4 if RMPRIM=""
SET RMPRIM="*"
+5 ;
+6 ; If item has new number from previous update then use the temp map
+7 IF $DATA(^TMP($JOB,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM))
Begin DoDot:1
+8 SET RMPRS=^TMP($JOB,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM)
+9 SET RMPR11("ITEM")=$PIECE(RMPRS,"^",3)
+10 QUIT
End DoDot:1
GOTO GETITMX
+11 ;
+12 ; If item number not already in use then can use it to create a new
+13 ; item in file 661.11
+14 IF '$DATA(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPRITM))
SET RMPR11("ITEM")=RMPRITM
GOTO GETITM1
+15 ;
+16 ; Ensure not duplicating Item number for different source
+17 SET RMPRGOT=0
+18 SET RMPRI=$ORDER(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPRITM,""))
+19 SET RMPRS=^RMPR(661.11,RMPRI,0)
+20 IF $PIECE(RMPRS,"^",5)=RMPR11("SOURCE")
Begin DoDot:1
+21 IF $PIECE(RMPRS,"^",8)=RMPR11("ITEM MASTER IEN")
SET RMPRGOT=1
QUIT
+22 IF $PIECE(RMPRS,"^",8)=""
Begin DoDot:2
+23 KILL RMPR11U
+24 SET RMPR11U("IEN")=RMPRI
+25 SET RMPR11U("ITEM MASTER IEN")=RMPR11("ITEM MASTER IEN")
+26 SET RMPRERR=$$UPD^RMPRPIX1(.RMPR11U)
+27 SET RMPRGOT=1
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 IF RMPRGOT
SET RMPR11("ITEM")=RMPRITM
GOTO GETITMX
+31 ; ensure new item will be created
SET RMPR11("ITEM")=""
GETITM1 SET RMPRS=$GET(^RMPR(661.1,RMPRHIEN,3,RMPRITM,0))
+1 SET RMPR11("DESCRIPTION")=$PIECE(RMPRS,"^",1)
+2 if RMPR11("DESCRIPTION")=""
SET RMPR11("DESCRIPTION")="NO DESCRIPTION"
+3 SET RMPRERR=$$CRE^RMPRPIX1(.RMPR11)
+4 ;
+5 ; map new HCPCS Item in 661.11 to old iens in 661.1
+6 SET RMPRS=""
+7 SET $PIECE(RMPRS,"^",1)=RMPR11("STATION")
+8 SET $PIECE(RMPRS,"^",2)=RMPR11("HCPCS")
+9 SET $PIECE(RMPRS,"^",3)=RMPR11("ITEM")
+10 SET $PIECE(RMPRS,"^",4)=RMPR11("IEN")
+11 SET ^TMP($JOB,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM)=RMPRS
GETITMX QUIT
