RMPRE29.m

RMPRE29 ;PHX/JLT,RVD-EDIT 2319 ;10/2/03  13:04

 ;;3.0;PROSTHETICS;**36,41,51,57,62,74,81,61,145,150,180,189,192**;Feb 09, 1996;Build 1

 ; Per VA Directive 6402, this routine should not be modified.

 ;RVD patch #62 - call PCE API to update patient care encounter.

 ;              - add a screen display if no changes to the HCPCS.

 ;RVD patch #74 - call $$STATCHK^ICPTAPIU to check if CPT Code is 

 ;                active for a given date.

 ;RVD patch #81 - roll back patch RMPR*3.0*74 and returns the screen

 ;                to the STATUS field of file #661.1.

 ;RVD patch #61 - added screen not to process stock issue entries.

 ;uses DBIA # 1995 & 1997.

 ;

 ;RB  patch 180 - Add model # and Contract # to editing capability

 ;

 W ! S DIC="^RMPR(660,",DIC(0)="AEMQZ",DIC("A")="Select PATIENT: "

 S DIC("W")="D EN^RMPRD1",RMEND=0

 S DIC("S")="I ($P(^(0),U,6)!($P(^(0),U,26)'="""")),($P(^(0),U,13)'=11)" W !

 D ^DIC G:+Y'>0 EXIT L +^RMPR(660,+Y,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT

 ;S (RMPRDA,DA)=+Y,DIE=DIC,DR="[RMPRE2319]" D ^DIE L -^RMPR(660,DA,0)

 S DIE=DIC,(RMPRDA,DA)=+Y

TYP1 ;edit type of transaction....

 S R1(0)=$G(^RMPR(660,RMPRDA,0)),R1(1)=$G(^(1)),R1("AM")=$G(^("AM"))

 S RMTOTCOS=$P(R1(0),U,16)

 S (RMHCPC,RMHCOLD)=$P(R1(1),U,4),(RMTYPE,RMTYPS)=$P(R1(0),U,4),(RMCAT,RMCATS)=$P(R1("AM"),U,3),(RMSPE,RMSPES)=$P(R1("AM"),U,4),RMSOUR=$P(R1(1),U,14)

TRAN K DIR S DIR(0)="660,2"

 ;S DIR("A")="Enter Type of Transaction: "

 S:$D(RMTYPS) DIR("B")=$S(RMTYPS="I":"INITIAL",RMTYPS="X":"REPAIR",RMTYPS="R":"REPLACE",RMTYPS="S":"SPARE",1:"")

 D ^DIR

 I $D(DUOUT)!$D(DTOUT) S RMEND=1 D SETED2 G QED2

 I Y="" W !,"Please enter type of Transaction!!" G TRAN

 S $P(R1(0),U,4)=Y,RMTYPE=Y

 S RMTYPS=$S(Y="I":"INITIAL",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")

PCAT K DIR S DIR(0)="660,62"

 S:$D(RMCATS) DIR("B")=$S(RMCATS=1:"SC/OP",RMCATS=2:"SC/IP",RMCATS=3:"NSC/IP",RMCATS=4:"NSC/OP",1:"")

 D ^DIR

 I $D(DUOUT)!$D(DTOUT) S RMEND=1 D SETED2 G QED2

 I Y="" W !,"Please enter Patient Category!!" G PCAT

 S RMCAT=Y

 S $P(R1("AM"),U,3)=Y,RMCATS=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")

 K DIR I RMCAT<4 S $P(R1("AM"),U,4)="" G HCPC

 S DIR(0)="660,63"

 S:$D(RMSPES) DIR("B")=$S(RMSPES=1:"SPECIAL LEGISLATION",RMSPES=2:"A&A",RMSPES=3:"PHC",RMSPES=4:"ELIGIBILITY REFORM",1:"")

 I RMCAT=4 D ^DIR I $D(DUOUT)!$D(DTOUT) S RMEND=1 D SETED2 G QED2

 I RMCAT=4 S $P(R1("AM"),U,4)=Y,RMSPE=Y,RMSPES=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")

 K DIR

 ;

HCPC ;set type and ask item and HCPCS

 D SETED2

 ;ask source

 N SRC

 S SRC=$P(R1(0),U,14)

 S DIE("NO^")="BACK"

 S DR="12;4;4.5" D ^DIE

 K DIE("NO^")

 I $D(DUOUT)!$D(DTOUT)!$D(Y) S RMEND=1 G QED2

 S R1(0)=$G(^RMPR(660,RMPRDA,0)),R1(1)=$G(^(1))

 I $P(R1(0),U,14)'=SRC S RMHCOLD=""

 S RMHCPC=$P(R1(1),U,4)

 W !,"OLD CPT MODIFER: ",$P(R1(1),U,6)

 ;if HCPCS was changed, Modifier must be changed

 I RMHCOLD'=RMHCPC D

 .S RDA=RMHCPC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660

 .D CPT^RMPRCPTU(RDA) S $P(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 .W !,"NEW CPT MODIFIER: ",RMCPT

 ;if HCPCS the same, ask user if want to edit modifier.

 E  D

 .S DIR(0)="Y",DIR("B")="N",DIR("A")="Would you like to edit the CPT Modifier "

 .D ^DIR Q:$D(DUOUT)!$D(DTOUT)

 .I (Y>0) D

 ..S RDA=RMHCPC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660

 ..D CPT^RMPRCPTU(RDA) S $P(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 ..K DIR

 ..W:RMCPT=$P(R1(1),U,6) !!,"***Based on the information given above, CPT modifier string has not changed!!!",!

 ..W:RMCPT'=$P(R1(1),U,6) !,"NEW CPT MODIFIER: ",RMCPT

 S DR="9.2;9;21;38.7;16;28" D ^DIE       ;RMPR*3.0*180

 I RMTOTCOS'=$P(^RMPR(660,DA,0),U,16) S DR="35////^S X=DUZ;36////^S X=DT" D ^DIE

 I $D(DTOUT)!('$G(Y))!($D(DUOUT)) D CHK

 ; update 664 for Lot Number , Model, Serial Number and Contract # Changes

 D UPD664

QED2 ;

 Q:$D(RMPREDT)

 L -^RMPR(660,RMPRDA,0)

 K DIR W ! S DIR(0)="Y",DIR("A")="Would You like to Edit another Entry (Y/N) " D ^DIR

 G:'$D(DTOUT)&(Y>0) RMPRE29

EXIT ;

 N RMPR,RMPRSITE D KILL^XUSCLEAN

 K DIC,DIE,DIR,%,X,Y

 Q

SETED2 ;set 660

 S ^RMPR(660,DA,0)=R1(0),^RMPR(660,DA,1)=R1(1),^RMPR(660,DA,"AM")=R1("AM")

 S DIK="^RMPR(660,",DA=RMPRDA D IX1^DIK K DIC

 D CHK

 Q

 ;

QUICK ;quick edit for HCPCS and type

 K RMCPT

 W ! S DIC="^RMPR(660,",DIC(0)="AEMNQZ",DIC("A")="Select NUMBER, or Patient: "

 S DIC("W")="D EN^RMPRD1"

 S DIC("S")="I $P(^(0),U,6)!($P(^(0),U,26)'="""")" W !

 D ^DIC G:+Y'>0 EXIT L +^RMPR(660,+Y,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT

 ;add source

 S (RMPRDA,DA)=+Y,DIE=DIC,DR="2;4.5"

 S R1(0)=$G(^RMPR(660,DA,0)),R1(1)=$G(^RMPR(660,DA,1))

 S RMTYPE=$P(R1(0),U,4),RMSOUR=$P(R1(0),U,14)

 S RMHCOLD=$P(R1(1),U,4)

 D ^DIE G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)!$D(Y) SET

 S RMHCNEW=$P($G(^RMPR(660,DA,1)),U,4)

 S RMTYPE=$P($G(^RMPR(660,DA,0)),U,4)

 S RDA=RMHCNEW_"^"_RMTYPE_"^"_RMSOUR_"^"_660

 W !,"OLD CPT MODIFER: ",$P(R1(1),U,6)

 I RMHCOLD'=RMHCNEW D

 .D CPT^RMPRCPTU(RDA)

 .W !,"NEW CPT MODIFIER: ",RMCPT

 .S $P(^RMPR(660,DA,1),U,6)=RMCPT

 I RMHCOLD=RMHCNEW D

 .W ! S DIR("B")="N",DIR(0)="Y",DIR("A")="Would You like to Edit CPT MODIFIER " D ^DIR

 .I $D(DTOUT)!('$G(Y)) K DIR Q

 .D CPT^RMPRCPTU(RDA)

 .W:RMCPT=$P(R1(1),U,6) !!,"***Based on the information given above, CPT modifier string has not changed!!!",!

 .W:RMCPT'=$P(R1(1),U,6) !,"NEW CPT MODIFIER: ",RMCPT

 .S $P(^RMPR(660,DA,1),U,6)=RMCPT

SET K DIR D CHK

 W ! S DIR(0)="Y",DIR("A")="Would You like to Edit another Entry (Y/N)" D ^DIR

 G:'$D(DTOUT)&(Y>0) QUICK^RMPRE29

 L -^RMPR(660,RMPRDA,0)

 D KILL^XUSCLEAN Q

 ;

CHK ;check for transaction changes

 S RMTYPE=$P($G(^RMPR(660,RMPRDA,0)),U,4)

 S RMHCPC=$P($G(^RMPR(660,RMPRDA,1)),U,4) Q:'$G(RMHCPC)

 S RMCPT1=$P($G(^RMPR(661.1,RMHCPC,4)),U,1)

 S RMCPT=$P($G(^RMPR(660,RMPRDA,1)),U,6)

 I ((RMTYPE="R")!(RMTYPE="X")),(RMCPT'["RP"),($G(^RMPR(661.1,RMHCPC,4))["RP") D ADDRP

 I ((RMTYPE="I")!(RMTYPE="S")),(RMCPT["RP") D DELRP

 I (RMSOUR="C"),(RMCPT["RR") D DELNU

 I (RMSOUR="C"),(RMCPT'["RR"),(RMCPT1["NU"),(RMCPT'["N") D ADDNU

 K RMHCPC,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA Q

 ;return to EDIT option

DELRP ;logic for deleting 'RP' modifier with transaction change.

 F RMCI=1:1:8 S RMC=$P(RMCPT,",",RMCI) I RMC="RP" S $P(RMCPT,",",RMCI)="" D

 .S RMF=$F(RMCPT,",,"),RMFPIECE=$E(RMCPT,1,RMF-2)

 .S RMLPIECE=$E(RMCPT,RMF,32),RMCPT=RMFPIECE_RMLPIECE,RMCLEN=$L(RMCPT)

 .I $E(RMCPT,1)="," S RMCPT=$E(RMCPT,2,RMCLEN)

 .I $E(RMCPT,RMCLEN)="," S RMCPT=$E(RMCPT,1,RMCLEN-1)

 .S $P(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 Q

DELNU ;logic for deleting 'NU' modifier.

 F RMCI=1:1:8 S RMC=$P(RMCPT,",",RMCI) I RMC="NU" S $P(RMCPT,",",RMCI)="" D

 .S RMF=$F(RMCPT,",,"),RMFPIECE=$E(RMCPT,1,RMF-2)

 .S RMLPIECE=$E(RMCPT,RMF,32),RMCPT=RMFPIECE_RMLPIECE,RMCLEN=$L(RMCPT)

 .I $E(RMCPT,1)="," S RMCPT=$E(RMCPT,2,RMCLEN)

 .I $E(RMCPT,RMCLEN)="," S RMCPT=$E(RMCPT,1,RMCLEN-1)

 .S $P(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 Q

 ;

ADDRP ;logic for adding 'RP' modifier with transaction change.

 S RMCPT=RMCPT_",RP" S $P(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 Q

ADDNU ;logic for adding 'NU' modifier.

 S RMCPT=RMCPT_",NU" S $P(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 Q

UPD664 ; update file 664 for Lot Number, Model, Serial Number, and Contract # Changes

 ; -- get the changes from 660

 N RMFDA,RMFDA1,RMORD,RMSSFI,RMN,RMI,RMNS,RMFERR

 F RMI=9,9.2,21,38.7 S RMFDA(RMI)=$$GET1^DIQ(660,DA,RMI)

 ; -- find the 664 IEN from the order number

 S RMORD=$$GET1^DIQ(660,DA,23)

 I RMORD="" Q

 S RMSSFI=$O(^RMPR(664,"G",RMORD,""))

 I RMSSFI="" Q

 ; -- scan 664.02 for DA in piece 13 - RMNS will be the subscript of interest

 S RMNS=0

 F  S RMNS=$O(^RMPR(664,RMSSFI,1,RMNS)) Q:+RMNS=0  Q:$P(^RMPR(664,RMSSFI,1,RMNS,0),U,13)=DA

 ; --save the fields into 664

 S RMN=""

 F RMI=15,15.4,15.6,13 S RMN=$O(RMFDA(RMN)) Q:RMN=""  D

 .S RMFDA1(664.02,RMNS_","_RMSSFI_",",RMI)=RMFDA(RMN)

 D UPDATE^DIE(,"RMFDA1",,"RMFERR")

 Q

 ; 

 ;END

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPRE29   8038     printed  Mar 13, 2025@21:39:09                                                                                                                                                                                                     Page 2

RMPRE29   ;PHX/JLT,RVD-EDIT 2319 ;10/2/03  13:04

 +1       ;;3.0;PROSTHETICS;**36,41,51,57,62,74,81,61,145,150,180,189,192**;Feb 09, 1996;Build 1

 +2       ; Per VA Directive 6402, this routine should not be modified.

 +3       ;RVD patch #62 - call PCE API to update patient care encounter.

 +4       ;              - add a screen display if no changes to the HCPCS.

 +5       ;RVD patch #74 - call $$STATCHK^ICPTAPIU to check if CPT Code is 

 +6       ;                active for a given date.

 +7       ;RVD patch #81 - roll back patch RMPR*3.0*74 and returns the screen

 +8       ;                to the STATUS field of file #661.1.

 +9       ;RVD patch #61 - added screen not to process stock issue entries.

 +10      ;uses DBIA # 1995 & 1997.

 +11      ;

 +12      ;RB  patch 180 - Add model # and Contract # to editing capability

 +13      ;

 +14       WRITE !

           SET DIC="^RMPR(660,"

           SET DIC(0)="AEMQZ"

           SET DIC("A")="Select PATIENT: "

 +15       SET DIC("W")="D EN^RMPRD1"

           SET RMEND=0

 +16       SET DIC("S")="I ($P(^(0),U,6)!($P(^(0),U,26)'="""")),($P(^(0),U,13)'=11)"

           WRITE !

 +17       DO ^DIC

           if +Y'>0

               GOTO EXIT

           LOCK +^RMPR(660,+Y,0):1

           IF $TEST=0

               WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"

               GOTO EXIT

 +18      ;S (RMPRDA,DA)=+Y,DIE=DIC,DR="[RMPRE2319]" D ^DIE L -^RMPR(660,DA,0)

 +19       SET DIE=DIC

           SET (RMPRDA,DA)=+Y

TYP1      ;edit type of transaction....

 +1        SET R1(0)=$GET(^RMPR(660,RMPRDA,0))

           SET R1(1)=$GET(^(1))

           SET R1("AM")=$GET(^("AM"))

 +2        SET RMTOTCOS=$PIECE(R1(0),U,16)

 +3        SET (RMHCPC,RMHCOLD)=$PIECE(R1(1),U,4)

           SET (RMTYPE,RMTYPS)=$PIECE(R1(0),U,4)

           SET (RMCAT,RMCATS)=$PIECE(R1("AM"),U,3)

           SET (RMSPE,RMSPES)=$PIECE(R1("AM"),U,4)

           SET RMSOUR=$PIECE(R1(1),U,14)

TRAN       KILL DIR

           SET DIR(0)="660,2"

 +1       ;S DIR("A")="Enter Type of Transaction: "

 +2        if $DATA(RMTYPS)

               SET DIR("B")=$SELECT(RMTYPS="I":"INITIAL",RMTYPS="X":"REPAIR",RMTYPS="R":"REPLACE",RMTYPS="S":"SPARE",1:"")

 +3        DO ^DIR

 +4        IF $DATA(DUOUT)!$DATA(DTOUT)

               SET RMEND=1

               DO SETED2

               GOTO QED2

 +5        IF Y=""

               WRITE !,"Please enter type of Transaction!!"

               GOTO TRAN

 +6        SET $PIECE(R1(0),U,4)=Y

           SET RMTYPE=Y

 +7        SET RMTYPS=$SELECT(Y="I":"INITIAL",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")

PCAT       KILL DIR

           SET DIR(0)="660,62"

 +1        if $DATA(RMCATS)

               SET DIR("B")=$SELECT(RMCATS=1:"SC/OP",RMCATS=2:"SC/IP",RMCATS=3:"NSC/IP",RMCATS=4:"NSC/OP",1:"")

 +2        DO ^DIR

 +3        IF $DATA(DUOUT)!$DATA(DTOUT)

               SET RMEND=1

               DO SETED2

               GOTO QED2

 +4        IF Y=""

               WRITE !,"Please enter Patient Category!!"

               GOTO PCAT

 +5        SET RMCAT=Y

 +6        SET $PIECE(R1("AM"),U,3)=Y

           SET RMCATS=$SELECT(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")

 +7        KILL DIR

           IF RMCAT<4

               SET $PIECE(R1("AM"),U,4)=""

               GOTO HCPC

 +8        SET DIR(0)="660,63"

 +9        if $DATA(RMSPES)

               SET DIR("B")=$SELECT(RMSPES=1:"SPECIAL LEGISLATION",RMSPES=2:"A&A",RMSPES=3:"PHC",RMSPES=4:"ELIGIBILITY REFORM",1:"")

 +10       IF RMCAT=4

               DO ^DIR

               IF $DATA(DUOUT)!$DATA(DTOUT)

                   SET RMEND=1

                   DO SETED2

                   GOTO QED2

 +11       IF RMCAT=4

               SET $PIECE(R1("AM"),U,4)=Y

               SET RMSPE=Y

               SET RMSPES=$SELECT(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")

 +12       KILL DIR

 +13      ;

HCPC      ;set type and ask item and HCPCS

 +1        DO SETED2

 +2       ;ask source

 +3        NEW SRC

 +4        SET SRC=$PIECE(R1(0),U,14)

 +5        SET DIE("NO^")="BACK"

 +6        SET DR="12;4;4.5"

           DO ^DIE

 +7        KILL DIE("NO^")

 +8        IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(Y)

               SET RMEND=1

               GOTO QED2

 +9        SET R1(0)=$GET(^RMPR(660,RMPRDA,0))

           SET R1(1)=$GET(^(1))

 +10       IF $PIECE(R1(0),U,14)'=SRC

               SET RMHCOLD=""

 +11       SET RMHCPC=$PIECE(R1(1),U,4)

 +12       WRITE !,"OLD CPT MODIFER: ",$PIECE(R1(1),U,6)

 +13      ;if HCPCS was changed, Modifier must be changed

 +14       IF RMHCOLD'=RMHCPC

               Begin DoDot:1

 +15               SET RDA=RMHCPC_"^"_$PIECE(R1(0),U,4)_"^"_$PIECE(R1(0),U,14)_"^"_660

 +16               DO CPT^RMPRCPTU(RDA)

                   SET $PIECE(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 +17               WRITE !,"NEW CPT MODIFIER: ",RMCPT

               End DoDot:1

 +18      ;if HCPCS the same, ask user if want to edit modifier.

 +19      IF '$TEST

               Begin DoDot:1

 +20               SET DIR(0)="Y"

                   SET DIR("B")="N"

                   SET DIR("A")="Would you like to edit the CPT Modifier "

 +21               DO ^DIR

                   if $DATA(DUOUT)!$DATA(DTOUT)

                       QUIT 

 +22               IF (Y>0)

                       Begin DoDot:2

 +23                       SET RDA=RMHCPC_"^"_$PIECE(R1(0),U,4)_"^"_$PIECE(R1(0),U,14)_"^"_660

 +24                       DO CPT^RMPRCPTU(RDA)

                           SET $PIECE(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 +25                       KILL DIR

 +26                       if RMCPT=$PIECE(R1(1),U,6)

                               WRITE !!,"***Based on the information given above, CPT modifier string has not changed!!!",!

 +27                       if RMCPT'=$PIECE(R1(1),U,6)

                               WRITE !,"NEW CPT MODIFIER: ",RMCPT

                       End DoDot:2

               End DoDot:1

 +28      ;RMPR*3.0*180

           SET DR="9.2;9;21;38.7;16;28"

           DO ^DIE

 +29       IF RMTOTCOS'=$PIECE(^RMPR(660,DA,0),U,16)

               SET DR="35////^S X=DUZ;36////^S X=DT"

               DO ^DIE

 +30       IF $DATA(DTOUT)!('$GET(Y))!($DATA(DUOUT))

               DO CHK

 +31      ; update 664 for Lot Number , Model, Serial Number and Contract # Changes

 +32       DO UPD664

QED2      ;

 +1        if $DATA(RMPREDT)

               QUIT 

 +2        LOCK -^RMPR(660,RMPRDA,0)

 +3        KILL DIR

           WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="Would You like to Edit another Entry (Y/N) "

           DO ^DIR

 +4        if '$DATA(DTOUT)&(Y>0)

               GOTO RMPRE29

EXIT      ;

 +1        NEW RMPR,RMPRSITE

           DO KILL^XUSCLEAN

 +2        KILL DIC,DIE,DIR,%,X,Y

 +3        QUIT 

SETED2    ;set 660

 +1        SET ^RMPR(660,DA,0)=R1(0)

           SET ^RMPR(660,DA,1)=R1(1)

           SET ^RMPR(660,DA,"AM")=R1("AM")

 +2        SET DIK="^RMPR(660,"

           SET DA=RMPRDA

           DO IX1^DIK

           KILL DIC

 +3        DO CHK

 +4        QUIT 

 +5       ;

QUICK     ;quick edit for HCPCS and type

 +1        KILL RMCPT

 +2        WRITE !

           SET DIC="^RMPR(660,"

           SET DIC(0)="AEMNQZ"

           SET DIC("A")="Select NUMBER, or Patient: "

 +3        SET DIC("W")="D EN^RMPRD1"

 +4        SET DIC("S")="I $P(^(0),U,6)!($P(^(0),U,26)'="""")"

           WRITE !

 +5        DO ^DIC

           if +Y'>0

               GOTO EXIT

           LOCK +^RMPR(660,+Y,0):1

           IF $TEST=0

               WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"

               GOTO EXIT

 +6       ;add source

 +7        SET (RMPRDA,DA)=+Y

           SET DIE=DIC

           SET DR="2;4.5"

 +8        SET R1(0)=$GET(^RMPR(660,DA,0))

           SET R1(1)=$GET(^RMPR(660,DA,1))

 +9        SET RMTYPE=$PIECE(R1(0),U,4)

           SET RMSOUR=$PIECE(R1(0),U,14)

 +10       SET RMHCOLD=$PIECE(R1(1),U,4)

 +11       DO ^DIE

           if $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!$DATA(Y)

               GOTO SET

 +12       SET RMHCNEW=$PIECE($GET(^RMPR(660,DA,1)),U,4)

 +13       SET RMTYPE=$PIECE($GET(^RMPR(660,DA,0)),U,4)

 +14       SET RDA=RMHCNEW_"^"_RMTYPE_"^"_RMSOUR_"^"_660

 +15       WRITE !,"OLD CPT MODIFER: ",$PIECE(R1(1),U,6)

 +16       IF RMHCOLD'=RMHCNEW

               Begin DoDot:1

 +17               DO CPT^RMPRCPTU(RDA)

 +18               WRITE !,"NEW CPT MODIFIER: ",RMCPT

 +19               SET $PIECE(^RMPR(660,DA,1),U,6)=RMCPT

               End DoDot:1

 +20       IF RMHCOLD=RMHCNEW

               Begin DoDot:1

 +21               WRITE !

                   SET DIR("B")="N"

                   SET DIR(0)="Y"

                   SET DIR("A")="Would You like to Edit CPT MODIFIER "

                   DO ^DIR

 +22               IF $DATA(DTOUT)!('$GET(Y))

                       KILL DIR

                       QUIT 

 +23               DO CPT^RMPRCPTU(RDA)

 +24               if RMCPT=$PIECE(R1(1),U,6)

                       WRITE !!,"***Based on the information given above, CPT modifier string has not changed!!!",!

 +25               if RMCPT'=$PIECE(R1(1),U,6)

                       WRITE !,"NEW CPT MODIFIER: ",RMCPT

 +26               SET $PIECE(^RMPR(660,DA,1),U,6)=RMCPT

               End DoDot:1

SET        KILL DIR

           DO CHK

 +1        WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="Would You like to Edit another Entry (Y/N)"

           DO ^DIR

 +2        if '$DATA(DTOUT)&(Y>0)

               GOTO QUICK^RMPRE29

 +3        LOCK -^RMPR(660,RMPRDA,0)

 +4        DO KILL^XUSCLEAN

           QUIT 

 +5       ;

CHK       ;check for transaction changes

 +1        SET RMTYPE=$PIECE($GET(^RMPR(660,RMPRDA,0)),U,4)

 +2        SET RMHCPC=$PIECE($GET(^RMPR(660,RMPRDA,1)),U,4)

           if '$GET(RMHCPC)

               QUIT 

 +3        SET RMCPT1=$PIECE($GET(^RMPR(661.1,RMHCPC,4)),U,1)

 +4        SET RMCPT=$PIECE($GET(^RMPR(660,RMPRDA,1)),U,6)

 +5        IF ((RMTYPE="R")!(RMTYPE="X"))

               IF (RMCPT'["RP")

                   IF ($GET(^RMPR(661.1,RMHCPC,4))["RP")

                       DO ADDRP

 +6        IF ((RMTYPE="I")!(RMTYPE="S"))

               IF (RMCPT["RP")

                   DO DELRP

 +7        IF (RMSOUR="C")

               IF (RMCPT["RR")

                   DO DELNU

 +8        IF (RMSOUR="C")

               IF (RMCPT'["RR")

                   IF (RMCPT1["NU")

                       IF (RMCPT'["N")

                           DO ADDNU

 +9        KILL RMHCPC,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA

           QUIT 

 +10      ;return to EDIT option

DELRP     ;logic for deleting 'RP' modifier with transaction change.

 +1        FOR RMCI=1:1:8

               SET RMC=$PIECE(RMCPT,",",RMCI)

               IF RMC="RP"

                   SET $PIECE(RMCPT,",",RMCI)=""

                   Begin DoDot:1

 +2                    SET RMF=$FIND(RMCPT,",,")

                       SET RMFPIECE=$EXTRACT(RMCPT,1,RMF-2)

 +3                    SET RMLPIECE=$EXTRACT(RMCPT,RMF,32)

                       SET RMCPT=RMFPIECE_RMLPIECE

                       SET RMCLEN=$LENGTH(RMCPT)

 +4                    IF $EXTRACT(RMCPT,1)=","

                           SET RMCPT=$EXTRACT(RMCPT,2,RMCLEN)

 +5                    IF $EXTRACT(RMCPT,RMCLEN)=","

                           SET RMCPT=$EXTRACT(RMCPT,1,RMCLEN-1)

 +6                    SET $PIECE(^RMPR(660,RMPRDA,1),U,6)=RMCPT

                   End DoDot:1

 +7        QUIT 

DELNU     ;logic for deleting 'NU' modifier.

 +1        FOR RMCI=1:1:8

               SET RMC=$PIECE(RMCPT,",",RMCI)

               IF RMC="NU"

                   SET $PIECE(RMCPT,",",RMCI)=""

                   Begin DoDot:1

 +2                    SET RMF=$FIND(RMCPT,",,")

                       SET RMFPIECE=$EXTRACT(RMCPT,1,RMF-2)

 +3                    SET RMLPIECE=$EXTRACT(RMCPT,RMF,32)

                       SET RMCPT=RMFPIECE_RMLPIECE

                       SET RMCLEN=$LENGTH(RMCPT)

 +4                    IF $EXTRACT(RMCPT,1)=","

                           SET RMCPT=$EXTRACT(RMCPT,2,RMCLEN)

 +5                    IF $EXTRACT(RMCPT,RMCLEN)=","

                           SET RMCPT=$EXTRACT(RMCPT,1,RMCLEN-1)

 +6                    SET $PIECE(^RMPR(660,RMPRDA,1),U,6)=RMCPT

                   End DoDot:1

 +7        QUIT 

 +8       ;

ADDRP     ;logic for adding 'RP' modifier with transaction change.

 +1        SET RMCPT=RMCPT_",RP"

           SET $PIECE(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 +2        QUIT 

ADDNU     ;logic for adding 'NU' modifier.

 +1        SET RMCPT=RMCPT_",NU"

           SET $PIECE(^RMPR(660,RMPRDA,1),U,6)=RMCPT

 +2        QUIT 

UPD664    ; update file 664 for Lot Number, Model, Serial Number, and Contract # Changes

 +1       ; -- get the changes from 660

 +2        NEW RMFDA,RMFDA1,RMORD,RMSSFI,RMN,RMI,RMNS,RMFERR

 +3        FOR RMI=9,9.2,21,38.7

               SET RMFDA(RMI)=$$GET1^DIQ(660,DA,RMI)

 +4       ; -- find the 664 IEN from the order number

 +5        SET RMORD=$$GET1^DIQ(660,DA,23)

 +6        IF RMORD=""

               QUIT 

 +7        SET RMSSFI=$ORDER(^RMPR(664,"G",RMORD,""))

 +8        IF RMSSFI=""

               QUIT 

 +9       ; -- scan 664.02 for DA in piece 13 - RMNS will be the subscript of interest

 +10       SET RMNS=0

 +11       FOR 

               SET RMNS=$ORDER(^RMPR(664,RMSSFI,1,RMNS))

               if +RMNS=0

                   QUIT 

               if $PIECE(^RMPR(664,RMSSFI,1,RMNS,0),U,13)=DA

                   QUIT 

 +12      ; --save the fields into 664

 +13       SET RMN=""

 +14       FOR RMI=15,15.4,15.6,13

               SET RMN=$ORDER(RMFDA(RMN))

               if RMN=""

                   QUIT 

               Begin DoDot:1

 +15               SET RMFDA1(664.02,RMNS_","_RMSSFI_",",RMI)=RMFDA(RMN)

               End DoDot:1

 +16       DO UPDATE^DIE(,"RMFDA1",,"RMFERR")

 +17       QUIT 

 +18      ; 

 +19      ;END