RMPRUTL4 ;HINES CIOFO/HNC - FIX RECORDS IN FILE 660 WITH NO AMIS GROUPER ;3/25/04 12:47
;;3.0;PROSTHETICS;**34,35,87,90**;Feb 09, 1996
;post init
I '$D(DUZ) W !,"DUZ NOT DEFINED!" Q
D DIV4^RMPRSIT,HOME^%ZIS G:$D(X) END
S RMPRA=0
F S RMPRA=$O(^RMPR(660,RMPRA)) Q:RMPRA'>0 D
.Q:$G(^RMPR(660,RMPRA,"AMS"))'=""
.Q:$G(^RMPR(660,RMPRA,0))=""
.Q:$P(^RMPR(660,RMPRA,0),U,15)["*"
.Q:$P(^RMPR(660,RMPRA,0),U,10)'=RMPR("STA")
.W "."
.L +^RMPR(669.9,RMPRSITE,0):9999 I $T=0 S RMPRG=DT_98
.I '$G(RMPRG) S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
.W RMPRG
.S $P(^RMPR(660,RMPRA,"AMS"),U,1)=RMPRG
.K RMPRG
W !,"ALL DONE"
K RMPRA,RMPR,RMPRSITE Q
CHG ;change nppd line ; HCPCS
S $P(^RMPR(661.1,2757,0),U,6)="R90 A"
S $P(^RMPR(661.1,2757,0),U,7)=""
Q
SERIAL ;enter product info for recall
D GETS^DIQ(660,DA,".02;4;4.5;7;11;23;24;27;89","E","RMPRX")
Q
END ;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRUTL4 971 printed Dec 13, 2024@02:38:03 Page 2
RMPRUTL4 ;HINES CIOFO/HNC - FIX RECORDS IN FILE 660 WITH NO AMIS GROUPER ;3/25/04 12:47
+1 ;;3.0;PROSTHETICS;**34,35,87,90**;Feb 09, 1996
+2 ;post init
+3 IF '$DATA(DUZ)
WRITE !,"DUZ NOT DEFINED!"
QUIT
+4 DO DIV4^RMPRSIT
DO HOME^%ZIS
if $DATA(X)
GOTO END
+5 SET RMPRA=0
+6 FOR
SET RMPRA=$ORDER(^RMPR(660,RMPRA))
if RMPRA'>0
QUIT
Begin DoDot:1
+7 if $GET(^RMPR(660,RMPRA,"AMS"))'=""
QUIT
+8 if $GET(^RMPR(660,RMPRA,0))=""
QUIT
+9 if $PIECE(^RMPR(660,RMPRA,0),U,15)["*"
QUIT
+10 if $PIECE(^RMPR(660,RMPRA,0),U,10)'=RMPR("STA")
QUIT
+11 WRITE "."
+12 LOCK +^RMPR(669.9,RMPRSITE,0):9999
IF $TEST=0
SET RMPRG=DT_98
+13 IF '$GET(RMPRG)
SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
SET RMPRG=RMPRG-1
SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG
LOCK -^RMPR(669.9,RMPRSITE,0)
+14 WRITE RMPRG
+15 SET $PIECE(^RMPR(660,RMPRA,"AMS"),U,1)=RMPRG
+16 KILL RMPRG
End DoDot:1
+17 WRITE !,"ALL DONE"
+18 KILL RMPRA,RMPR,RMPRSITE
QUIT
CHG ;change nppd line ; HCPCS
+1 SET $PIECE(^RMPR(661.1,2757,0),U,6)="R90 A"
+2 SET $PIECE(^RMPR(661.1,2757,0),U,7)=""
+3 QUIT
SERIAL ;enter product info for recall
+1 DO GETS^DIQ(660,DA,".02;4;4.5;7;11;23;24;27;89","E","RMPRX")
+2 QUIT
END ;END
