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 ---[H[J[2J[HRMPRE29 8038 printed Apr 09, 2024@21:35:59 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
