RMPOPIN1 ;HINCIOFO/RVD - POST INIT (CONVERSION ROUTINE) ;01/05/00
;;3.0;PROSTHETICS;**44,46**;Feb 09, 1996
;
W !,"INVALID ENTRY POINT...."
Q
START ;conversion of 442 ien and po
W !!,"***Converting file 442 IEN and PO. Please be patient.***"
F RSI=0:0 S RSI=$O(^RMPO(665.72,RSI)) Q:RSI'>0 F RDA=0:0 S RDA=$O(^RMPO(665.72,RSI,1,RDA)) Q:RDA'>0 F REN=0:0 S REN=$O(^RMPO(665.72,RSI,1,RDA,2,REN)) Q:REN'>0 D
. S RMDAT0=$G(^RMPO(665.72,RSI,1,RDA,2,REN,0))
. Q:$P(RMDAT0,U,2)
. S RMIEN=$P(RMDAT0,U,3)
. S RMPO=$P(RMDAT0,U,4)
. Q:RMIEN="" ;nothing to convert
. Q:$D(^PRC(442,RMIEN,0)) ;entry already been converted
. S X1=$P(RMDAT0,U,5),X2=REN,X=RMIEN D DE^XUSHSHP I X D
. .S $P(^RMPO(665.72,RSI,1,RDA,2,REN,0),U,3)=X
. .S:X'="" ^RMPO(665.72,RSI,1,RDA,2,"C",X,REN)=""
. .W !,RDA," ",REN," ",X
. S X1=$P(RMDAT0,U,5),X2=REN,X=RMPO D DE^XUSHSHP D
. .S $P(^RMPO(665.72,RSI,1,RDA,2,REN,0),U,4)=X
. .S:X'="" ^RMPO(665.72,RSI,1,RDA,2,"D",X,REN)=""
. .W !,RDA," ",REN," ",X
W !!,"***Done Converting file 442 IEN and PO***"
DES ;remove duplicate/extra HCPCS description 'B' cross-reference &
;clean-up the 'F' cross-reference.
W !!,"***Starting clean-up of HCPCS Description***"
K ^RMPR(661.1,"F") S DIK(1)=".01^F"
F RI=0:0 S RI=$O(^RMPR(661.1,RI)) Q:RI'>0 K ^RMPR(661.1,RI,2,"B") F RJ=0:0 S RJ=$O(^RMPR(661.1,RI,2,RJ)) Q:RJ'>0 D
.S RD=$G(^RMPR(661.1,RI,2,RJ,0)) I $L(RD)>30 S RD=$E(RD,1,30)
.S ^RMPR(661.1,RI,2,"B",RD,RJ)=""
.S DA(1)=RI,DA=RJ,DIK="^RMPR(661.1,"_DA(1)_",2,"
.D EN1^DIK
W !!,"***Done clean-up of HCPCS Description***"
S $P(^RMPR(661.1,128,0),"^",7)="900 E"
EXIT ;Kill variables
K RMIEN,RMPO,RMDAT0,X1,X2,REN,RSI,RDA,RI,RJ,RD,DIK,DA,X
Q
46 ;deletes 'AD' cross-ref of file #665
S RADX="AD" D DELIX^DDMOD(665,19.2,RADX)
K DIK,RADX
Q
POST46 ;re-index the field #10,19.2
W !!,"*** Reindexing 'AHO & AD' cross reference of file #665....."
K ^RMPR(665,"AD")
S DIK="^RMPR(665,",DIK(1)="19.2^AHO" D ENALL^DIK
F I=0:0 S I=$O(^RMPR(665,I)) Q:I'>0 F J=0:0 S J=$O(^RMPR(665,I,1,J)) Q:J'>0 S DIK="^RMPR(665,",DA(1)=I,DA=J,DIK=DIK_DA(1)_",1,",DIK(1)="10^AD" D EN1^DIK
K DIK,RADX,DA,I,J
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOPIN1 2170 printed Nov 22, 2024@17:41:21 Page 2
RMPOPIN1 ;HINCIOFO/RVD - POST INIT (CONVERSION ROUTINE) ;01/05/00
+1 ;;3.0;PROSTHETICS;**44,46**;Feb 09, 1996
+2 ;
+3 WRITE !,"INVALID ENTRY POINT...."
+4 QUIT
START ;conversion of 442 ien and po
+1 WRITE !!,"***Converting file 442 IEN and PO. Please be patient.***"
+2 FOR RSI=0:0
SET RSI=$ORDER(^RMPO(665.72,RSI))
if RSI'>0
QUIT
FOR RDA=0:0
SET RDA=$ORDER(^RMPO(665.72,RSI,1,RDA))
if RDA'>0
QUIT
FOR REN=0:0
SET REN=$ORDER(^RMPO(665.72,RSI,1,RDA,2,REN))
if REN'>0
QUIT
Begin DoDot:1
+3 SET RMDAT0=$GET(^RMPO(665.72,RSI,1,RDA,2,REN,0))
+4 if $PIECE(RMDAT0,U,2)
QUIT
+5 SET RMIEN=$PIECE(RMDAT0,U,3)
+6 SET RMPO=$PIECE(RMDAT0,U,4)
+7 ;nothing to convert
if RMIEN=""
QUIT
+8 ;entry already been converted
if $DATA(^PRC(442,RMIEN,0))
QUIT
+9 SET X1=$PIECE(RMDAT0,U,5)
SET X2=REN
SET X=RMIEN
DO DE^XUSHSHP
IF X
Begin DoDot:2
+10 SET $PIECE(^RMPO(665.72,RSI,1,RDA,2,REN,0),U,3)=X
+11 if X'=""
SET ^RMPO(665.72,RSI,1,RDA,2,"C",X,REN)=""
+12 WRITE !,RDA," ",REN," ",X
End DoDot:2
+13 SET X1=$PIECE(RMDAT0,U,5)
SET X2=REN
SET X=RMPO
DO DE^XUSHSHP
Begin DoDot:2
+14 SET $PIECE(^RMPO(665.72,RSI,1,RDA,2,REN,0),U,4)=X
+15 if X'=""
SET ^RMPO(665.72,RSI,1,RDA,2,"D",X,REN)=""
+16 WRITE !,RDA," ",REN," ",X
End DoDot:2
End DoDot:1
+17 WRITE !!,"***Done Converting file 442 IEN and PO***"
DES ;remove duplicate/extra HCPCS description 'B' cross-reference &
+1 ;clean-up the 'F' cross-reference.
+2 WRITE !!,"***Starting clean-up of HCPCS Description***"
+3 KILL ^RMPR(661.1,"F")
SET DIK(1)=".01^F"
+4 FOR RI=0:0
SET RI=$ORDER(^RMPR(661.1,RI))
if RI'>0
QUIT
KILL ^RMPR(661.1,RI,2,"B")
FOR RJ=0:0
SET RJ=$ORDER(^RMPR(661.1,RI,2,RJ))
if RJ'>0
QUIT
Begin DoDot:1
+5 SET RD=$GET(^RMPR(661.1,RI,2,RJ,0))
IF $LENGTH(RD)>30
SET RD=$EXTRACT(RD,1,30)
+6 SET ^RMPR(661.1,RI,2,"B",RD,RJ)=""
+7 SET DA(1)=RI
SET DA=RJ
SET DIK="^RMPR(661.1,"_DA(1)_",2,"
+8 DO EN1^DIK
End DoDot:1
+9 WRITE !!,"***Done clean-up of HCPCS Description***"
+10 SET $PIECE(^RMPR(661.1,128,0),"^",7)="900 E"
EXIT ;Kill variables
+1 KILL RMIEN,RMPO,RMDAT0,X1,X2,REN,RSI,RDA,RI,RJ,RD,DIK,DA,X
+2 QUIT
46 ;deletes 'AD' cross-ref of file #665
+1 SET RADX="AD"
DO DELIX^DDMOD(665,19.2,RADX)
+2 KILL DIK,RADX
+3 QUIT
POST46 ;re-index the field #10,19.2
+1 WRITE !!,"*** Reindexing 'AHO & AD' cross reference of file #665....."
+2 KILL ^RMPR(665,"AD")
+3 SET DIK="^RMPR(665,"
SET DIK(1)="19.2^AHO"
DO ENALL^DIK
+4 FOR I=0:0
SET I=$ORDER(^RMPR(665,I))
if I'>0
QUIT
FOR J=0:0
SET J=$ORDER(^RMPR(665,I,1,J))
if J'>0
QUIT
SET DIK="^RMPR(665,"
SET DA(1)=I
SET DA=J
SET DIK=DIK_DA(1)_",1,"
SET DIK(1)="10^AD"
DO EN1^DIK
+5 KILL DIK,RADX,DA,I,J
+6 QUIT
