RMPRUTL4.m

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 ---RMPRUTL4   971     printed  Apr 09, 2024@21:38:07                                                                                                                                                                                                     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