RMPRED6 ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;9/29/1994
;;3.0;PROSTHETICS;**19,33,35,46,41,53,90**;Feb 09, 1996
EN ;EDIT STOCK ISSUES
D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT^RMPRED4
S DIC("S")="I ($P(^(0),U,13)=11!($P(^(0),U,13)=12)) I $P(^(0),U,10)=RMPR(""STA"")" I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
S DIC="^RMPR(660,",DIC(0)="AEMQ",DIC("A")="Select PATIENT: ",DIC("W")="D ^RMPRD1" D ^DIC G:Y<0 EXIT^RMPRED4
S RMPRIEN=+Y
L +^RMPR(660,+Y):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT^RMPRED4
S (RMDFN,DFN)=$P(^RMPR(660,+Y,0),U,2)
S RMPRF=$P(^RMPR(660,+Y,0),U,13)
INVSE S %X=DIC_+Y_",",%Y="R1(" D %XY^%RCR
S:'$D(R1(2)) R1(2)=""
D DEM^VADPT
S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
S (RMHCPC,RMHCNEW,RMHCOLD)=$P($G(R1(1)),U,4),REDIT=1,RMPRUCST=0
S (RMQNEW,RMQOLD)=$P($G(R1(0)),U,7)
S (RMLOCNEW,RMLOCOLD,RMITNEW,RMITOLD)=""
S RMSTOCK=$P($G(R1(1)),U,5)
I $G(RMSTOCK) S R6612=$G(^RMPR(661.2,RMSTOCK,0)),(RMLOC,RMLOCNEW,RMLOCOLD)=$P(R6612,U,16),(RMIT,RMITNEW,RMITOLD)=$P(R6612,U,9)
S R12(0)=R1(0),RMPRREL=$P(R1(0),U,16)
I $D(^RMPR(660,RMPRIEN,1)),+$P(^RMPR(660,RMPRIEN,1),U,3) S (RMPRIP,RIPOLD)=$P(^PRCP(445,$P(^RMPR(660,RMPRIEN,1),U,3),0),U)
K DIC S R3("D")="",R4("D")=""
G SET
;
CO ;DISPLAYS STOCK ISSUE
D CHK^RMPRED5
D NODE2^RMPRSTI
D ^RMPRST2
EDX ;POST
S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
S DIR("A")="Woul you like to POST/EDIT/DELETE this entry",DIR("B")="P",DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"
D ^DIR K DIR G:Y="P" POST^RMPRED4 G:Y="D" DEL1^RMPRED4
G:Y="E" EDT
I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G EXIT^RMPRED4
DEL ;
S DIR(0)="SBO^E:EDIT;D:DELETE",DIR("B")="E"
S DIR("A")="Would you like to EDIT/DELETE this Transaction",DIR("?")="Answer 'E' to EDIT the transaction or 'D' to DELETE the transaction." D ^DIR G:$D(DIRUT) EXIT^RMPRED4
I Y="E" G EDT
I Y="D" G DEL1^RMPRED4
;
EDT ;edit patient 2319
W @IOF,!?30,RMPRNAM,!
;
EDU S RMTY=$P(R1(0),U,4)
K DIR W ! S DIR(0)="660,2",DIR("B")=$S(RMTY="I":"INITIAL ISSUE",RMTY="X":"REPAIR",RMTY="R":"REPLACE",RMTY="S":"SPARE",RMTY=5:"RENTAL",1:"")
D ^DIR G:$D(DIRUT) CO S $P(R1(0),U,4)=Y,$P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",Y=5:"RENTAL",1:"")
S DIR(0)="660,62",DIR("B")=$P(R4("D"),U,3) D ^DIR G:$D(DIRUT) CO S $P(R1("AM"),U,3)=Y,$P(R4("D"),U,3)=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2
K DIR I Y=4 S DIR(0)="660,63" S:$P(R1("AM"),U,4)?1N.N DIR("B")=$P(R4("D"),U,4) D ^DIR G:$D(DUOUT)!$D(DTOUT) CO G:$D(DIRUT)!(X="") 2
I $P(R1("AM"),U,3)=4 S $P(R1("AM"),U,4)=Y,$P(R4("D"),U,4)=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
;
2 S DIC(0)="AEQM",DIC=661 S:$P(R1(0),U,6) DIC("B")=$P(^RMPR(661,$P(R1(0),U,6),0),U) S DIC("A")="ITEM: "
K DIC("S") D ^DIC
I $P(R3("D"),U,6)&$D(DUOUT) G CO
I $D(DUOUT)!$D(DTOUT) G CO
I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G 2
S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2) K DIC,Y,X
;
LOC ;ask for location
S (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
K DIC,Y,X,RQUIT,DTOUT,DUOUT
S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
S:RMLOCOLD'="" DIC("B")=RMLOCOLD
S DIC="^RMPR(661.3,",DIC(0)="AEQM"
S DIC("A")="Enter Pros Location: " D MIX^DIC1
I $D(DUOUT)!$D(DTOUT) G CO
I X="" W !,"This is a mandatory field!!!",! G LOC
S RMLOC=+Y
G:'$D(^RMPR(661.3,RMLOC,0)) LOC
;
HCPCS ;HCPCS code
K DIC,RMR,RMX,RQUIT S DIC("A")="PSAS HCPCS: ",DA(1)=RMLOC,RMF=1
I $P(R1(1),U,4)&(RMLOCOLD=RMLOC) S DIC("B")=$P(R1(1),U,4)
S DIC="^RMPR(661.3,"_DA(1)_",1,",DIC(0)="AEMNZ"
S DIC("W")="S RZ=$P(^RMPR(661.3,RMLOC,1,+Y,0),U,1) I RZ W ?30,$P(^RMPR(661.1,RZ,0),U,2)"
D ^DIC I $D(DUOUT)!$D(DTOUT) G LOC
I X="" W !,"This is a mandatory field!!!",! G HCPCS
S (RMHCNEW,RMDAHC)=$P($G(^RMPR(661.3,RMLOC,1,+Y,0)),U,1)
I $G(RMDAHC),$P(^RMPR(661.1,RMDAHC,0),U,5)'=1 D INACT^RMPRSTI G HCPCS
S RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1),RMHCDA=+Y
S RDES=$P(^RMPR(661.1,RMDAHC,0),U,2)
;
CPT ;ask for CPT Modifier
K DIC,Y,RQUIT
S RDA=RMDAHC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660
D:$D(RMCPT) CHK^RMPRED5
W:$G(REDIT) !,"OLD CPT MODIFIER: ",$P(R1(1),U,6)
I RMHCOLD'=RMDAHC D CPT^RMPRCPTU(RDA) G:$D(DUOUT)!$D(DTOUT) LIST^RMPRSTE S $P(R1(1),U,6)=$G(RMCPT) W:$G(REDIT) !,"NEW CPT MODIFIER: ",$G(RMCPT)
I RMHCOLD'="",(RMHCOLD=RMDAHC),$G(REDIT) D
.S DIR(0)="Y",DIR("A")="Would you like to Edit CPT MODIFIER Entry ",DIR("B")="N" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
.I $G(Y) D CPT^RMPRCPTU(RDA) Q:$D(DUOUT)!$D(DUOUT) S $P(R1(1),U,6)=$G(RMCPT) W !,"NEW CPT MODIFIER: ",$G(RMCPT)
K DIR
;
;D ITEM^RMPR5NU1(REDIT,RMLOC,RMLOCOLD,RMDAHC,RMHCOLD,RMHCDA,RMIT)
;
ITEM ;ask for PSAS Item to to edit.
S DA(2)=RMLOC,DA(1)=RMHCDA K DIC,RMU3,RMUBA,RQUIT
S DIC("A")="Enter PSAS Item: ",DIC(0)="AEMNQ"
I RMDAHC=RMHCOLD S DIC("B")=$G(RMIT)
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
D ^DIC I $D(DUOUT)!$D(DTOUT) G LOC
I X="" W !,"This is a mandatory field!!!",! G ITEM
S RMITDA=+Y,RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
S RMUBA=$P(RMU3,U,2)
S (RMITNEW,RMIT)=$P(RMU3,U,1),RMDES=RMIT K DIC("B"),DIC("S")
I (RMITNEW'=RMITOLD),(RMUBA<1) D LOWBA^RMPRSTI G LOC
;
I $D(RMLOC),$D(RMHCDA),$D(RMITDA) S RMSO=$$SOURCE^RMPR5NU1
I $D(RMSO),RMSO="" D MESSO^RMPRSTI G LOC
S:$D(RMSO) $P(R1(0),U,14)=RMSO
S $P(R3("D"),U,14)=$S(RMSO="C":"COMMERCIAL",RMSO="V":"VA",1:"")
I $P(R1(1),U,4)'="",$D(DUOUT) G CO
I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G LOC
I $G(RMLOC),$G(RMHCDA),$G(RMITDA) S RMPRUCST=$$COST^RMPR5NU1
I '$G(RMPRUCST) D MESSI^RMPRSTI G LOC
S:$G(REDIT) $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7),$P(R3("D"),U,16)=RMPRUCST*$P(R1(0),U,7)
S $P(R1(1),U,4)=RMDAHC,$P(R1(0),U,22)=$P(^RMPR(661.1,RMDAHC,0),U,4)
S RMLOCNEW=RMLOC,RMHCNEW=RMDAHC
D NODE2^RMPRSTI
K DIC
;
VEN0 ;process vendor
K DIC,DIR
I $D(RMLOC),$D(RMHCDA),$D(RMITDA) S DIC("B")=$$VEND^RMPR5NU1
S DIC="^PRC(440,",DIC(0)="AEQM" D ^DIC I $D(DUOUT)!$D(DTOUT) G CO
G:+Y<0 VEN0
S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIR,DIC
CP G ^RMPRED4
;
SET ;set the original variables.
S $P(R3("D"),U,14)=$S($P(R1(0),U,14)="V":"VA",$P(R1(0),U,14)="C":"COMMERCIAL",1:"")
S $P(R3("D"),U,4)=$S($P(R1(0),U,4)="I":"INITIAL ISSUE",$P(R1(0),U,4)="X":"REPAIR",$P(R1(0),U,4)="R":"REPLACE",$P(R1(0),U,4)="S":"SPARE",$P(R1(0),U,4)="5":"RENTAL",1:"")
S $P(R4("D"),U,3)=$S($P(R1("AM"),U,3)=1:"SC/OP",$P(R1("AM"),U,3)=2:"SC/IP",$P(R1("AM"),U,3)=3:"NSC/IP",$P(R1("AM"),U,3)=4:"NSC/OP")
S:$P(R1("AM"),U,3)=4&($P(R1("AM"),U,4)) $P(R4("D"),U,4)=$S($P(R1("AM"),U,4)=1:"SPECIAL LEGISLATION",$P(R1("AM"),U,4)=2:"A&A",$P(R1("AM"),U,4)=3:"PHC",$P(R1("AM"),U,4)=4:"ELIGIBILITY REFORM",1:"")
S RMHCOLD=$P($G(R1(1)),U,4),RMPRPF=$P(R1(0),U,13),RMQOLD=$P(R1(0),U,7)
S RMSO=$P(R1(0),U,14)
I $G(RMQOLD),$P($G(R1(0)),U,16) S RMPRUCST=$P(R1(0),U,16)/RMQOLD
S $P(R3("D"),U,6)=$P(^RMPR(661,$P(R1(0),U,6),0),U,1),RITOLD=$P(R1(0),U,6),RMQOLD=$P(R1(0),U,7),Y=$P(R1(0),U,12) G:Y="" CO D DD^%DT S $P(R3("D"),U,12)=Y
D ^RMPRST2 G DEL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRED6 7258 printed Oct 16, 2024@18:34:58 Page 2
RMPRED6 ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;9/29/1994
+1 ;;3.0;PROSTHETICS;**19,33,35,46,41,53,90**;Feb 09, 1996
EN ;EDIT STOCK ISSUES
+1 DO HOME^%ZIS
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT^RMPRED4
+2 SET DIC("S")="I ($P(^(0),U,13)=11!($P(^(0),U,13)=12)) I $P(^(0),U,10)=RMPR(""STA"")"
IF RMPRSITE=1
SET DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
+3 SET DIC="^RMPR(660,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select PATIENT: "
SET DIC("W")="D ^RMPRD1"
DO ^DIC
if Y<0
GOTO EXIT^RMPRED4
+4 SET RMPRIEN=+Y
+5 LOCK +^RMPR(660,+Y):1
IF $TEST=0
WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"
GOTO EXIT^RMPRED4
+6 SET (RMDFN,DFN)=$PIECE(^RMPR(660,+Y,0),U,2)
+7 SET RMPRF=$PIECE(^RMPR(660,+Y,0),U,13)
INVSE SET %X=DIC_+Y_","
SET %Y="R1("
DO %XY^%RCR
+1 if '$DATA(R1(2))
SET R1(2)=""
+2 DO DEM^VADPT
+3 SET RMPRNAM=$PIECE(VADM(1),U)
SET RMPRSSN=$PIECE(VADM(2),U)
+4 SET (RMHCPC,RMHCNEW,RMHCOLD)=$PIECE($GET(R1(1)),U,4)
SET REDIT=1
SET RMPRUCST=0
+5 SET (RMQNEW,RMQOLD)=$PIECE($GET(R1(0)),U,7)
+6 SET (RMLOCNEW,RMLOCOLD,RMITNEW,RMITOLD)=""
+7 SET RMSTOCK=$PIECE($GET(R1(1)),U,5)
+8 IF $GET(RMSTOCK)
SET R6612=$GET(^RMPR(661.2,RMSTOCK,0))
SET (RMLOC,RMLOCNEW,RMLOCOLD)=$PIECE(R6612,U,16)
SET (RMIT,RMITNEW,RMITOLD)=$PIECE(R6612,U,9)
+9 SET R12(0)=R1(0)
SET RMPRREL=$PIECE(R1(0),U,16)
+10 IF $DATA(^RMPR(660,RMPRIEN,1))
IF +$PIECE(^RMPR(660,RMPRIEN,1),U,3)
SET (RMPRIP,RIPOLD)=$PIECE(^PRCP(445,$PIECE(^RMPR(660,RMPRIEN,1),U,3),0),U)
+11 KILL DIC
SET R3("D")=""
SET R4("D")=""
+12 GOTO SET
+13 ;
CO ;DISPLAYS STOCK ISSUE
+1 DO CHK^RMPRED5
+2 DO NODE2^RMPRSTI
+3 DO ^RMPRST2
EDX ;POST
+1 SET DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
+2 SET DIR("A")="Woul you like to POST/EDIT/DELETE this entry"
SET DIR("B")="P"
SET DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"
+3 DO ^DIR
KILL DIR
if Y="P"
GOTO POST^RMPRED4
if Y="D"
GOTO DEL1^RMPRED4
+4 if Y="E"
GOTO EDT
+5 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
GOTO EXIT^RMPRED4
DEL ;
+1 SET DIR(0)="SBO^E:EDIT;D:DELETE"
SET DIR("B")="E"
+2 SET DIR("A")="Would you like to EDIT/DELETE this Transaction"
SET DIR("?")="Answer 'E' to EDIT the transaction or 'D' to DELETE the transaction."
DO ^DIR
if $DATA(DIRUT)
GOTO EXIT^RMPRED4
+3 IF Y="E"
GOTO EDT
+4 IF Y="D"
GOTO DEL1^RMPRED4
+5 ;
EDT ;edit patient 2319
+1 WRITE @IOF,!?30,RMPRNAM,!
+2 ;
EDU SET RMTY=$PIECE(R1(0),U,4)
+1 KILL DIR
WRITE !
SET DIR(0)="660,2"
SET DIR("B")=$SELECT(RMTY="I":"INITIAL ISSUE",RMTY="X":"REPAIR",RMTY="R":"REPLACE",RMTY="S":"SPARE",RMTY=5:"RENTAL",1:"")
+2 DO ^DIR
if $DATA(DIRUT)
GOTO CO
SET $PIECE(R1(0),U,4)=Y
SET $PIECE(R3("D"),U,4)=$SELECT(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",Y=5:"RENTAL",1:"")
+3 SET DIR(0)="660,62"
SET DIR("B")=$PIECE(R4("D"),U,3)
DO ^DIR
if $DATA(DIRUT)
GOTO CO
SET $PIECE(R1("AM"),U,3)=Y
SET $PIECE(R4("D"),U,3)=$SELECT(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
+4 IF Y<4
SET $PIECE(R1("AM"),U,4)=""
SET $PIECE(R4("D"),U,4)=""
GOTO 2
+5 KILL DIR
IF Y=4
SET DIR(0)="660,63"
if $PIECE(R1("AM"),U,4)?1N.N
SET DIR("B")=$PIECE(R4("D"),U,4)
DO ^DIR
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO CO
if $DATA(DIRUT)!(X="")
GOTO 2
+6 IF $PIECE(R1("AM"),U,3)=4
SET $PIECE(R1("AM"),U,4)=Y
SET $PIECE(R4("D"),U,4)=$SELECT(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
+7 ;
2 SET DIC(0)="AEQM"
SET DIC=661
if $PIECE(R1(0),U,6)
SET DIC("B")=$PIECE(^RMPR(661,$PIECE(R1(0),U,6),0),U)
SET DIC("A")="ITEM: "
+1 KILL DIC("S")
DO ^DIC
+2 IF $PIECE(R3("D"),U,6)&$DATA(DUOUT)
GOTO CO
+3 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CO
+4 IF +Y'>0
WRITE !!,?5,$CHAR(7),"This is a required response. Enter '^' to exit",!
GOTO 2
+5 SET $PIECE(R1(0),U,6)=+Y
SET $PIECE(R3("D"),U,6)=$PIECE(Y,U,2)
KILL DIC,Y,X
+6 ;
LOC ;ask for location
+1 SET (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
+2 KILL DIC,Y,X,RQUIT,DTOUT,DUOUT
+3 SET DZ="??"
SET D="B"
SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
+4 if RMLOCOLD'=""
SET DIC("B")=RMLOCOLD
+5 SET DIC="^RMPR(661.3,"
SET DIC(0)="AEQM"
+6 SET DIC("A")="Enter Pros Location: "
DO MIX^DIC1
+7 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CO
+8 IF X=""
WRITE !,"This is a mandatory field!!!",!
GOTO LOC
+9 SET RMLOC=+Y
+10 if '$DATA(^RMPR(661.3,RMLOC,0))
GOTO LOC
+11 ;
HCPCS ;HCPCS code
+1 KILL DIC,RMR,RMX,RQUIT
SET DIC("A")="PSAS HCPCS: "
SET DA(1)=RMLOC
SET RMF=1
+2 IF $PIECE(R1(1),U,4)&(RMLOCOLD=RMLOC)
SET DIC("B")=$PIECE(R1(1),U,4)
+3 SET DIC="^RMPR(661.3,"_DA(1)_",1,"
SET DIC(0)="AEMNZ"
+4 SET DIC("W")="S RZ=$P(^RMPR(661.3,RMLOC,1,+Y,0),U,1) I RZ W ?30,$P(^RMPR(661.1,RZ,0),U,2)"
+5 DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO LOC
+6 IF X=""
WRITE !,"This is a mandatory field!!!",!
GOTO HCPCS
+7 SET (RMHCNEW,RMDAHC)=$PIECE($GET(^RMPR(661.3,RMLOC,1,+Y,0)),U,1)
+8 IF $GET(RMDAHC)
IF $PIECE(^RMPR(661.1,RMDAHC,0),U,5)'=1
DO INACT^RMPRSTI
GOTO HCPCS
+9 SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
SET RMHCDA=+Y
+10 SET RDES=$PIECE(^RMPR(661.1,RMDAHC,0),U,2)
+11 ;
CPT ;ask for CPT Modifier
+1 KILL DIC,Y,RQUIT
+2 SET RDA=RMDAHC_"^"_$PIECE(R1(0),U,4)_"^"_$PIECE(R1(0),U,14)_"^"_660
+3 if $DATA(RMCPT)
DO CHK^RMPRED5
+4 if $GET(REDIT)
WRITE !,"OLD CPT MODIFIER: ",$PIECE(R1(1),U,6)
+5 IF RMHCOLD'=RMDAHC
DO CPT^RMPRCPTU(RDA)
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO LIST^RMPRSTE
SET $PIECE(R1(1),U,6)=$GET(RMCPT)
if $GET(REDIT)
WRITE !,"NEW CPT MODIFIER: ",$GET(RMCPT)
+6 IF RMHCOLD'=""
IF (RMHCOLD=RMDAHC)
IF $GET(REDIT)
Begin DoDot:1
+7 SET DIR(0)="Y"
SET DIR("A")="Would you like to Edit CPT MODIFIER Entry "
SET DIR("B")="N"
DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+8 IF $GET(Y)
DO CPT^RMPRCPTU(RDA)
if $DATA(DUOUT)!$DATA(DUOUT)
QUIT
SET $PIECE(R1(1),U,6)=$GET(RMCPT)
WRITE !,"NEW CPT MODIFIER: ",$GET(RMCPT)
End DoDot:1
+9 KILL DIR
+10 ;
+11 ;D ITEM^RMPR5NU1(REDIT,RMLOC,RMLOCOLD,RMDAHC,RMHCOLD,RMHCDA,RMIT)
+12 ;
ITEM ;ask for PSAS Item to to edit.
+1 SET DA(2)=RMLOC
SET DA(1)=RMHCDA
KILL DIC,RMU3,RMUBA,RQUIT
+2 SET DIC("A")="Enter PSAS Item: "
SET DIC(0)="AEMNQ"
+3 IF RMDAHC=RMHCOLD
SET DIC("B")=$GET(RMIT)
+4 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
+5 DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO LOC
+6 IF X=""
WRITE !,"This is a mandatory field!!!",!
GOTO ITEM
+7 SET RMITDA=+Y
SET RMU3=$GET(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
+8 SET RMUBA=$PIECE(RMU3,U,2)
+9 SET (RMITNEW,RMIT)=$PIECE(RMU3,U,1)
SET RMDES=RMIT
KILL DIC("B"),DIC("S")
+10 IF (RMITNEW'=RMITOLD)
IF (RMUBA<1)
DO LOWBA^RMPRSTI
GOTO LOC
+11 ;
+12 IF $DATA(RMLOC)
IF $DATA(RMHCDA)
IF $DATA(RMITDA)
SET RMSO=$$SOURCE^RMPR5NU1
+13 IF $DATA(RMSO)
IF RMSO=""
DO MESSO^RMPRSTI
GOTO LOC
+14 if $DATA(RMSO)
SET $PIECE(R1(0),U,14)=RMSO
+15 SET $PIECE(R3("D"),U,14)=$SELECT(RMSO="C":"COMMERCIAL",RMSO="V":"VA",1:"")
+16 IF $PIECE(R1(1),U,4)'=""
IF $DATA(DUOUT)
GOTO CO
+17 IF $GET(RMLOC)
IF '($GET(RMHCDA)&$GET(RMITDA))
WRITE !,"PSAS Item was not selected!!"
GOTO LOC
+18 IF $GET(RMLOC)
IF $GET(RMHCDA)
IF $GET(RMITDA)
SET RMPRUCST=$$COST^RMPR5NU1
+19 IF '$GET(RMPRUCST)
DO MESSI^RMPRSTI
GOTO LOC
+20 if $GET(REDIT)
SET $PIECE(R1(0),U,16)=RMPRUCST*$PIECE(R1(0),U,7)
SET $PIECE(R3("D"),U,16)=RMPRUCST*$PIECE(R1(0),U,7)
+21 SET $PIECE(R1(1),U,4)=RMDAHC
SET $PIECE(R1(0),U,22)=$PIECE(^RMPR(661.1,RMDAHC,0),U,4)
+22 SET RMLOCNEW=RMLOC
SET RMHCNEW=RMDAHC
+23 DO NODE2^RMPRSTI
+24 KILL DIC
+25 ;
VEN0 ;process vendor
+1 KILL DIC,DIR
+2 IF $DATA(RMLOC)
IF $DATA(RMHCDA)
IF $DATA(RMITDA)
SET DIC("B")=$$VEND^RMPR5NU1
+3 SET DIC="^PRC(440,"
SET DIC(0)="AEQM"
DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CO
+4 if +Y<0
GOTO VEN0
+5 SET $PIECE(R1(0),U,9)=+Y
SET $PIECE(R3("D"),U,9)=$PIECE(Y,U,2)
KILL DIR,DIC
CP GOTO ^RMPRED4
+1 ;
SET ;set the original variables.
+1 SET $PIECE(R3("D"),U,14)=$SELECT($PIECE(R1(0),U,14)="V":"VA",$PIECE(R1(0),U,14)="C":"COMMERCIAL",1:"")
+2 SET $PIECE(R3("D"),U,4)=$SELECT($PIECE(R1(0),U,4)="I":"INITIAL ISSUE",$PIECE(R1(0),U,4)="X":"REPAIR",$PIECE(R1(0),U,4)="R":"REPLACE",$PIECE(R1(0),U,4)="S":"SPARE",$PIECE(R1(0),U,4)="5":"RENTAL",1:"")
+3 SET $PIECE(R4("D"),U,3)=$SELECT($PIECE(R1("AM"),U,3)=1:"SC/OP",$PIECE(R1("AM"),U,3)=2:"SC/IP",$PIECE(R1("AM"),U,3)=3:"NSC/IP",$PIECE(R1("AM"),U,3)=4:"NSC/OP")
+4 if $PIECE(R1("AM"),U,3)=4&($PIECE(R1("AM"),U,4))
SET $PIECE(R4("D"),U,4)=$SELECT($PIECE(R1("AM"),U,4)=1:"SPECIAL LEGISLATION",$PIECE(R1("AM"),U,4)=2:"A&A",$PIECE(R1("AM"),U,4)=3:"PHC",$PIECE(R1("AM"),U,4)=4:"ELIGIBILITY REFORM",1:"")
+5 SET RMHCOLD=$PIECE($GET(R1(1)),U,4)
SET RMPRPF=$PIECE(R1(0),U,13)
SET RMQOLD=$PIECE(R1(0),U,7)
+6 SET RMSO=$PIECE(R1(0),U,14)
+7 IF $GET(RMQOLD)
IF $PIECE($GET(R1(0)),U,16)
SET RMPRUCST=$PIECE(R1(0),U,16)/RMQOLD
+8 SET $PIECE(R3("D"),U,6)=$PIECE(^RMPR(661,$PIECE(R1(0),U,6),0),U,1)
SET RITOLD=$PIECE(R1(0),U,6)
SET RMQOLD=$PIECE(R1(0),U,7)
SET Y=$PIECE(R1(0),U,12)
if Y=""
GOTO CO
DO DD^%DT
SET $PIECE(R3("D"),U,12)=Y
+9 DO ^RMPRST2
GOTO DEL
+10 QUIT
