RMPRPIUG ;HINCIO/ODJ - CONVERT OLD PIP TO NEW PIP ;7/30/02 08:19
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** CONV - Convert old PIP files to the new design (start)
; Should be run as post init in patch 61
; No re-start allowed and all Prosthetic Inventory
; menu options including Stock Issue and quick edit
; should be disabled.
; If conversion needs to be re-run then you must call
; KILL^RMPRPIXZ before running this utility.
;
CONV I $D(^RMPR(661.5,"B")) D G CONVX ;don't convert if 661.5 has a rec
. I '$D(IO("Q")) D
.. W !!
.. W "** File 661.5 already exists, aborting conversion, please log NOIS"
.. Q
. Q
DUZ S RMPRDUZ=$$GETUSR^RMPRPIU0(DUZ)
I RMPRDUZ="" D G CONVX ;need valid DUZ
. I '$D(IO("Q")) D
.. W !!
.. W "** Need valid DUZ variable set"
.. Q
. Q
I '$D(IO("Q")) D
. W !,"PIP Old to New file conversion starting."
. Q
K ^TMP($J)
D LOCN^RMPRPIUJ ; create locations (old to new map in ^TMP($J,"LOCN")
D CONV^RMPRPIUI ; create commercial items that exist in 661.3
D CONV1A ; create current inventory (from 661.3)
D CONV^RMPRPIUH ; create issues (from 660 and 661.2)
D REC^RMPRPIUK ; create initial balancing reconciliations
D BAL^RMPRPIUK ; create balance history (661.9)
D UNIT^RMPRPIUJ ; update unit of issue (661.7)
K ^TMP($J)
RENDX S DIK="^RMPR(661.11," D IXALL^DIK
I '$D(IO("Q")) D
. W !,"PIP Old to New file conversion complete.",!
. Q
CONVX Q
;
; Convert current inventory based on file 661.3
; Main Loop on location
CONV1A N RMPRL,RMPRHREC,RMPRERR,RMPR5,RMPRI,RMPRREC,RMPRITM,X,Y,DA,RMPRSS
N RMPRH,RMPRHIEN,RMPR4,RMPR6,RMPR,RMPR11,RMPRSRC,RMPRTODT,RMPR41
I '$D(IO("Q")) D
. W !,"Creating Current Inventory - file 661.7 "
. Q
D NOW^%DTC S RMPRTODT=$P(%,".",1)
S RMPRL=0
CONV1 S RMPRL=$O(^RMPR(661.3,RMPRL))
I '+RMPRL G CONV1AX
I '$D(^TMP($J,"LOCN",RMPRL)) G CONV1
S RMPR5("IEN")=^TMP($J,"LOCN",RMPRL)
S RMPRREC=^RMPR(661.3,RMPRL,0)
S RMPR5("STATION")=$P(RMPRREC,"^",3)
;
; Loop on the HCPCS node in 661.3
K ^TMP($J,"H")
S RMPRH=0
CONV2 S RMPRH=$O(^RMPR(661.3,RMPRL,1,RMPRH))
I '$D(IO("Q")) D
. W:$X=79 ! W "."
. Q
I '+RMPRH D G CONV1
. D TMPH(.RMPR5)
. K ^TMP($J,"H")
. Q
S RMPRREC=$G(^RMPR(661.3,RMPRL,1,RMPRH,0))
S RMPRHIEN=$P(RMPRREC,"^",1) ;ien to 661.1
I RMPRHIEN="" G CONV2 ;ignore if null 661.1 ptr
I '$D(^RMPR(661.1,RMPRHIEN,0)) G CONV2 ;ignore if bad ptr
S RMPRHREC=^RMPR(661.1,RMPRHIEN,0)
K RMPR11
S RMPR11("STATION")=RMPR5("STATION")
S RMPR11("STATION IEN")=RMPR5("STATION")
S RMPR11("HCPCS")=$P(RMPRHREC,"^",1) ;get HCPCS code from 661.1
I RMPR11("HCPCS")="" G CONV2 ;ignore if null HCPCS code
;
; Loop on HCPCS Item node in 661.3
S RMPRI=0
CONV3 S RMPRI=$O(^RMPR(661.3,RMPRL,1,RMPRH,1,RMPRI))
I '+RMPRI G CONV2
S RMPRREC=$G(^RMPR(661.3,RMPRL,1,RMPRH,1,RMPRI,0))
I $P($P(RMPRREC,"^",1),"-",1)'=RMPR11("HCPCS") G CONV3 ;bad HCPCS
S RMPR11("SOURCE")="C"
I $P(RMPRREC,"^",9)="V" S RMPR11("SOURCE")="V"
S RMPRITM=$P($P(RMPRREC,"^",1),"-",2)
I RMPRITM="" G CONV3
S RMPR11("UNIT")=$P(RMPRREC,"^",4)
S RMPR7("UNIT")=$P(RMPRREC,"^",4)
K RMPR6
S RMPR6("QUANTITY")=+$P(RMPRREC,"^",2)
S RMPR6("VALUE")=+$P(RMPRREC,"^",3)
S RMPR6("VALUE")=$J(RMPR6("VALUE"),0,2)
S RMPR6("VENDOR IEN")=$P(RMPRREC,"^",5)
K RMPR4
S RMPR4("RE-ORDER QTY")=+$P(RMPRREC,"^",6)
K RMPR41
S RMPR41("ORDER QTY")=+$P(RMPRREC,"^",11)
D GETITM^RMPRPIUH(.RMPR11,RMPRHIEN,RMPRITM)
;
; Create HCPCS Item Re-Order record 661.4
I '$D(^RMPR(661.4,"ASLHI",RMPR11("STATION IEN"),RMPR5("IEN"),RMPR11("HCPCS"),RMPR11("ITEM"))) D
. S RMPRERR=$$CRE^RMPRPIX4(.RMPR4,.RMPR11,.RMPR5)
. Q
;
; Save in Temp global for later update
I RMPR6("VENDOR IEN")="" G CONV3
I $D(^TMP($J,"H",RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("VENDOR IEN"))) D
. S RMPRSS=^TMP($J,"H",RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("VENDOR IEN"))
. S $P(RMPRSS,"^",1)=$P(RMPRSS,"^",1)+RMPR6("QUANTITY")
. S $P(RMPRSS,"^",2)=$P(RMPRSS,"^",2)+RMPR6("VALUE")
. Q
E D
. S RMPRSS=RMPR6("QUANTITY")
. S $P(RMPRSS,"^",2)=RMPR6("VALUE")
. Q
S RMPRSS=RMPRSS_U_$G(RMPR11("UNIT"))
S ^TMP($J,"H",RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("VENDOR IEN"))=RMPRSS
;
; If there is an order quantity then save it to file 661.41
I RMPR41("ORDER QTY")>0 D
. S RMPR41("VENDOR")=RMPR6("VENDOR IEN")
. S RMPR41("DATE ORDER")=RMPRTODT
. S RMPR41("STATUS")="O"
. S RMPRERR=$$CRE^RMPRPIXN(.RMPR41,.RMPR11)
. Q
G CONV3 ;next item in 661.3
;
; Process the ^TMP($J,"H") global just created
TMPH(RMPR5) ;
N RMPRH,RMPRI,RMPRV,RMPR,RMPR11,RMPRERR,RMPRSS,RMPR6,RMPRUCST
S RMPRH=""
F S RMPRH=$O(^TMP($J,"H",RMPRH)) Q:RMPRH="" D
. S RMPRI=""
. F S RMPRI=$O(^TMP($J,"H",RMPRH,RMPRI)) Q:RMPRI="" D
.. S RMPRV=""
.. F S RMPRV=$O(^TMP($J,"H",RMPRH,RMPRI,RMPRV)) Q:RMPRV="" D
... S RMPRSS=^TMP($J,"H",RMPRH,RMPRI,RMPRV)
... K RMPR6
... S RMPR6("QUANTITY")=+$P(RMPRSS,"^",1)
... S RMPR6("VALUE")=+$P(RMPRSS,"^",2)
... S RMPR6("UNIT")=+$P(RMPRSS,"^",3)
... S RMPR6("VENDOR IEN")=RMPRV
... K RMPR11
... S RMPR11("STATION")=RMPR5("STATION")
... S RMPR11("STATION IEN")=RMPR5("STATION")
... S RMPR11("HCPCS")=RMPRH
... S RMPR11("ITEM")=RMPRI
... S RMPR11("UNIT")=$P(RMPRSS,U,3)
... ;
... ; If quantity<0 then create a reconciliation gain
... ; of the amount followed by a 0 reconciliation
... I RMPR6("QUANTITY")<0 D
.... K RMPR
.... S RMPR("QUANTITY")=0-RMPR6("QUANTITY")
.... S RMPR("VALUE")=$S(RMPR6("VALUE")<0:0-RMPR6("VALUE"),1:RMPR6("VALUE"))
.... S RMPR("NEW UNIT COST")=$J(RMPR("VALUE")/RMPR("QUANTITY"),0,2)
.... S RMPRUCST=RMPR("NEW UNIT COST")
.... S RMPR("VENDOR IEN")=RMPR6("VENDOR IEN")
.... S RMPRERR=$$REC^RMPRPIU9(.RMPR,.RMPR11,.RMPR5)
.... K RMPR
.... S RMPR("QUANTITY")=0
.... S RMPR("VENDOR IEN")=RMPR6("VENDOR IEN")
.... S RMPR("NEW UNIT COST")=RMPRUCST
.... S RMPRERR=$$REC^RMPRPIU9(.RMPR,.RMPR11,.RMPR5)
.... Q
... ;
... ; If +VE qty. just record as a gain
... E D
.... S:RMPR6("VALUE")<0 RMPR6("VALUE")=0-RMPR6("VALUE")
.... S RMPR6("NEW UNIT COST")=0
.... S:RMPR6("QUANTITY") RMPR6("NEW UNIT COST")=$J(RMPR6("VALUE")/RMPR6("QUANTITY"),0,2)
.... S RMPRERR=$$REC^RMPRPIU9(.RMPR6,.RMPR11,.RMPR5)
.... Q
... Q
.. Q
. Q
TMPHX K ^TMP($J,"H")
Q
;
;exit
CONV1AX K ^TMP($J,"H")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIUG 6442 printed Dec 13, 2024@02:36:26 Page 2
RMPRPIUG ;HINCIO/ODJ - CONVERT OLD PIP TO NEW PIP ;7/30/02 08:19
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** CONV - Convert old PIP files to the new design (start)
+5 ; Should be run as post init in patch 61
+6 ; No re-start allowed and all Prosthetic Inventory
+7 ; menu options including Stock Issue and quick edit
+8 ; should be disabled.
+9 ; If conversion needs to be re-run then you must call
+10 ; KILL^RMPRPIXZ before running this utility.
+11 ;
CONV ;don't convert if 661.5 has a rec
IF $DATA(^RMPR(661.5,"B"))
Begin DoDot:1
+1 IF '$DATA(IO("Q"))
Begin DoDot:2
+2 WRITE !!
+3 WRITE "** File 661.5 already exists, aborting conversion, please log NOIS"
+4 QUIT
End DoDot:2
+5 QUIT
End DoDot:1
GOTO CONVX
DUZ SET RMPRDUZ=$$GETUSR^RMPRPIU0(DUZ)
+1 ;need valid DUZ
IF RMPRDUZ=""
Begin DoDot:1
+2 IF '$DATA(IO("Q"))
Begin DoDot:2
+3 WRITE !!
+4 WRITE "** Need valid DUZ variable set"
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
GOTO CONVX
+7 IF '$DATA(IO("Q"))
Begin DoDot:1
+8 WRITE !,"PIP Old to New file conversion starting."
+9 QUIT
End DoDot:1
+10 KILL ^TMP($JOB)
+11 ; create locations (old to new map in ^TMP($J,"LOCN")
DO LOCN^RMPRPIUJ
+12 ; create commercial items that exist in 661.3
DO CONV^RMPRPIUI
+13 ; create current inventory (from 661.3)
DO CONV1A
+14 ; create issues (from 660 and 661.2)
DO CONV^RMPRPIUH
+15 ; create initial balancing reconciliations
DO REC^RMPRPIUK
+16 ; create balance history (661.9)
DO BAL^RMPRPIUK
+17 ; update unit of issue (661.7)
DO UNIT^RMPRPIUJ
+18 KILL ^TMP($JOB)
RENDX SET DIK="^RMPR(661.11,"
DO IXALL^DIK
+1 IF '$DATA(IO("Q"))
Begin DoDot:1
+2 WRITE !,"PIP Old to New file conversion complete.",!
+3 QUIT
End DoDot:1
CONVX QUIT
+1 ;
+2 ; Convert current inventory based on file 661.3
+3 ; Main Loop on location
CONV1A NEW RMPRL,RMPRHREC,RMPRERR,RMPR5,RMPRI,RMPRREC,RMPRITM,X,Y,DA,RMPRSS
+1 NEW RMPRH,RMPRHIEN,RMPR4,RMPR6,RMPR,RMPR11,RMPRSRC,RMPRTODT,RMPR41
+2 IF '$DATA(IO("Q"))
Begin DoDot:1
+3 WRITE !,"Creating Current Inventory - file 661.7 "
+4 QUIT
End DoDot:1
+5 DO NOW^%DTC
SET RMPRTODT=$PIECE(%,".",1)
+6 SET RMPRL=0
CONV1 SET RMPRL=$ORDER(^RMPR(661.3,RMPRL))
+1 IF '+RMPRL
GOTO CONV1AX
+2 IF '$DATA(^TMP($JOB,"LOCN",RMPRL))
GOTO CONV1
+3 SET RMPR5("IEN")=^TMP($JOB,"LOCN",RMPRL)
+4 SET RMPRREC=^RMPR(661.3,RMPRL,0)
+5 SET RMPR5("STATION")=$PIECE(RMPRREC,"^",3)
+6 ;
+7 ; Loop on the HCPCS node in 661.3
+8 KILL ^TMP($JOB,"H")
+9 SET RMPRH=0
CONV2 SET RMPRH=$ORDER(^RMPR(661.3,RMPRL,1,RMPRH))
+1 IF '$DATA(IO("Q"))
Begin DoDot:1
+2 if $X=79
WRITE !
WRITE "."
+3 QUIT
End DoDot:1
+4 IF '+RMPRH
Begin DoDot:1
+5 DO TMPH(.RMPR5)
+6 KILL ^TMP($JOB,"H")
+7 QUIT
End DoDot:1
GOTO CONV1
+8 SET RMPRREC=$GET(^RMPR(661.3,RMPRL,1,RMPRH,0))
+9 ;ien to 661.1
SET RMPRHIEN=$PIECE(RMPRREC,"^",1)
+10 ;ignore if null 661.1 ptr
IF RMPRHIEN=""
GOTO CONV2
+11 ;ignore if bad ptr
IF '$DATA(^RMPR(661.1,RMPRHIEN,0))
GOTO CONV2
+12 SET RMPRHREC=^RMPR(661.1,RMPRHIEN,0)
+13 KILL RMPR11
+14 SET RMPR11("STATION")=RMPR5("STATION")
+15 SET RMPR11("STATION IEN")=RMPR5("STATION")
+16 ;get HCPCS code from 661.1
SET RMPR11("HCPCS")=$PIECE(RMPRHREC,"^",1)
+17 ;ignore if null HCPCS code
IF RMPR11("HCPCS")=""
GOTO CONV2
+18 ;
+19 ; Loop on HCPCS Item node in 661.3
+20 SET RMPRI=0
CONV3 SET RMPRI=$ORDER(^RMPR(661.3,RMPRL,1,RMPRH,1,RMPRI))
+1 IF '+RMPRI
GOTO CONV2
+2 SET RMPRREC=$GET(^RMPR(661.3,RMPRL,1,RMPRH,1,RMPRI,0))
+3 ;bad HCPCS
IF $PIECE($PIECE(RMPRREC,"^",1),"-",1)'=RMPR11("HCPCS")
GOTO CONV3
+4 SET RMPR11("SOURCE")="C"
+5 IF $PIECE(RMPRREC,"^",9)="V"
SET RMPR11("SOURCE")="V"
+6 SET RMPRITM=$PIECE($PIECE(RMPRREC,"^",1),"-",2)
+7 IF RMPRITM=""
GOTO CONV3
+8 SET RMPR11("UNIT")=$PIECE(RMPRREC,"^",4)
+9 SET RMPR7("UNIT")=$PIECE(RMPRREC,"^",4)
+10 KILL RMPR6
+11 SET RMPR6("QUANTITY")=+$PIECE(RMPRREC,"^",2)
+12 SET RMPR6("VALUE")=+$PIECE(RMPRREC,"^",3)
+13 SET RMPR6("VALUE")=$JUSTIFY(RMPR6("VALUE"),0,2)
+14 SET RMPR6("VENDOR IEN")=$PIECE(RMPRREC,"^",5)
+15 KILL RMPR4
+16 SET RMPR4("RE-ORDER QTY")=+$PIECE(RMPRREC,"^",6)
+17 KILL RMPR41
+18 SET RMPR41("ORDER QTY")=+$PIECE(RMPRREC,"^",11)
+19 DO GETITM^RMPRPIUH(.RMPR11,RMPRHIEN,RMPRITM)
+20 ;
+21 ; Create HCPCS Item Re-Order record 661.4
+22 IF '$DATA(^RMPR(661.4,"ASLHI",RMPR11("STATION IEN"),RMPR5("IEN"),RMPR11("HCPCS"),RMPR11("ITEM")))
Begin DoDot:1
+23 SET RMPRERR=$$CRE^RMPRPIX4(.RMPR4,.RMPR11,.RMPR5)
+24 QUIT
End DoDot:1
+25 ;
+26 ; Save in Temp global for later update
+27 IF RMPR6("VENDOR IEN")=""
GOTO CONV3
+28 IF $DATA(^TMP($JOB,"H",RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("VENDOR IEN")))
Begin DoDot:1
+29 SET RMPRSS=^TMP($JOB,"H",RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("VENDOR IEN"))
+30 SET $PIECE(RMPRSS,"^",1)=$PIECE(RMPRSS,"^",1)+RMPR6("QUANTITY")
+31 SET $PIECE(RMPRSS,"^",2)=$PIECE(RMPRSS,"^",2)+RMPR6("VALUE")
+32 QUIT
End DoDot:1
+33 IF '$TEST
Begin DoDot:1
+34 SET RMPRSS=RMPR6("QUANTITY")
+35 SET $PIECE(RMPRSS,"^",2)=RMPR6("VALUE")
+36 QUIT
End DoDot:1
+37 SET RMPRSS=RMPRSS_U_$GET(RMPR11("UNIT"))
+38 SET ^TMP($JOB,"H",RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("VENDOR IEN"))=RMPRSS
+39 ;
+40 ; If there is an order quantity then save it to file 661.41
+41 IF RMPR41("ORDER QTY")>0
Begin DoDot:1
+42 SET RMPR41("VENDOR")=RMPR6("VENDOR IEN")
+43 SET RMPR41("DATE ORDER")=RMPRTODT
+44 SET RMPR41("STATUS")="O"
+45 SET RMPRERR=$$CRE^RMPRPIXN(.RMPR41,.RMPR11)
+46 QUIT
End DoDot:1
+47 ;next item in 661.3
GOTO CONV3
+48 ;
+49 ; Process the ^TMP($J,"H") global just created
TMPH(RMPR5) ;
+1 NEW RMPRH,RMPRI,RMPRV,RMPR,RMPR11,RMPRERR,RMPRSS,RMPR6,RMPRUCST
+2 SET RMPRH=""
+3 FOR
SET RMPRH=$ORDER(^TMP($JOB,"H",RMPRH))
if RMPRH=""
QUIT
Begin DoDot:1
+4 SET RMPRI=""
+5 FOR
SET RMPRI=$ORDER(^TMP($JOB,"H",RMPRH,RMPRI))
if RMPRI=""
QUIT
Begin DoDot:2
+6 SET RMPRV=""
+7 FOR
SET RMPRV=$ORDER(^TMP($JOB,"H",RMPRH,RMPRI,RMPRV))
if RMPRV=""
QUIT
Begin DoDot:3
+8 SET RMPRSS=^TMP($JOB,"H",RMPRH,RMPRI,RMPRV)
+9 KILL RMPR6
+10 SET RMPR6("QUANTITY")=+$PIECE(RMPRSS,"^",1)
+11 SET RMPR6("VALUE")=+$PIECE(RMPRSS,"^",2)
+12 SET RMPR6("UNIT")=+$PIECE(RMPRSS,"^",3)
+13 SET RMPR6("VENDOR IEN")=RMPRV
+14 KILL RMPR11
+15 SET RMPR11("STATION")=RMPR5("STATION")
+16 SET RMPR11("STATION IEN")=RMPR5("STATION")
+17 SET RMPR11("HCPCS")=RMPRH
+18 SET RMPR11("ITEM")=RMPRI
+19 SET RMPR11("UNIT")=$PIECE(RMPRSS,U,3)
+20 ;
+21 ; If quantity<0 then create a reconciliation gain
+22 ; of the amount followed by a 0 reconciliation
+23 IF RMPR6("QUANTITY")<0
Begin DoDot:4
+24 KILL RMPR
+25 SET RMPR("QUANTITY")=0-RMPR6("QUANTITY")
+26 SET RMPR("VALUE")=$SELECT(RMPR6("VALUE")<0:0-RMPR6("VALUE"),1:RMPR6("VALUE"))
+27 SET RMPR("NEW UNIT COST")=$JUSTIFY(RMPR("VALUE")/RMPR("QUANTITY"),0,2)
+28 SET RMPRUCST=RMPR("NEW UNIT COST")
+29 SET RMPR("VENDOR IEN")=RMPR6("VENDOR IEN")
+30 SET RMPRERR=$$REC^RMPRPIU9(.RMPR,.RMPR11,.RMPR5)
+31 KILL RMPR
+32 SET RMPR("QUANTITY")=0
+33 SET RMPR("VENDOR IEN")=RMPR6("VENDOR IEN")
+34 SET RMPR("NEW UNIT COST")=RMPRUCST
+35 SET RMPRERR=$$REC^RMPRPIU9(.RMPR,.RMPR11,.RMPR5)
+36 QUIT
End DoDot:4
+37 ;
+38 ; If +VE qty. just record as a gain
+39 IF '$TEST
Begin DoDot:4
+40 if RMPR6("VALUE")<0
SET RMPR6("VALUE")=0-RMPR6("VALUE")
+41 SET RMPR6("NEW UNIT COST")=0
+42 if RMPR6("QUANTITY")
SET RMPR6("NEW UNIT COST")=$JUSTIFY(RMPR6("VALUE")/RMPR6("QUANTITY"),0,2)
+43 SET RMPRERR=$$REC^RMPRPIU9(.RMPR6,.RMPR11,.RMPR5)
+44 QUIT
End DoDot:4
+45 QUIT
End DoDot:3
+46 QUIT
End DoDot:2
+47 QUIT
End DoDot:1
TMPHX KILL ^TMP($JOB,"H")
+1 QUIT
+2 ;
+3 ;exit
CONV1AX KILL ^TMP($JOB,"H")
+1 QUIT
