RMPRPIYE ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;3/8/05 08:04
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
; RVD #61 - phase III of PIP enhancement.
;DBIA #227 - Read access to .01 field of file #445.
;DBIA #800 - FILEMAN look up of file #440.
;
EN ;EDIT STOCK ISSUES
K RMPR6,RMPR11,RMPR11I,RMPR5,RMPR7I,RMPR7,RMPR9,RMPR1
D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT^RMPRPIYF
S DIC("S")="S RM661=$G(^RMPR(660,+Y,1)) I ($P(^RMPR(660,+Y,0),U,13)=11),($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^RMPRPIYF
S RMPRIEN=+Y
L +^RMPR(660,+Y):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT^RMPRPIYF
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 %X=DIC_+Y_",",%Y="R1BCK(" D %XY^%RCR
S:'$D(R1(2)) R1(2)="" S:'$D(R1BCK(2)) R1BCK(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),(RSTCK,REDIT)=1,RMPRCOST=0
S RMCPT=$P(R1(1),U,6)
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.6,RMSTOCK,0)),(RMLOC,RMLOCNEW,RMLOCOLD)=$P(R6612,U,14),(RMIT,RMITNEW,RMITOLD)=$P(R1(2),U,1)
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 ^RMPRPIYK
;
EDX ;POST
S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
S DIR("A")="Would 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^RMPRPIYF G:Y="D" DEL1^RMPRPIYF
G:Y="E" EDT
I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G EXIT^RMPRPIYF
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
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT) G EXIT^RMPRPIYF
I Y="E" G EDT
I Y="D" G DEL1^RMPRPIYF
;
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",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",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: "
;
HCPCS ;scanning an item is mandatory.
W ! D SCAN^RMPRPIYS
I $P(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P")) G CO^RMPRPIYE
I RMPREXC="^" G CO^RMPRPIYE
I RMPREXC="P" G CO^RMPRPIYE
I RMPREXC="T" G CO^RMPRPIYE
I RMPRBARC="",$G(REDIT) G VEN0
I RMPRBARC="" G HCPCS
D HCPCS3^RMPRPIY1
;set ALL variables based on the scanned label
S $P(R1(0),U,6)=$G(RMPR11I("ITEM MASTER IEN"))
S RMPRCOST=0
I RMPR7("VALUE")>0,RMPR7("QUANTITY")>0 S RMPRCOST=RMPR7("VALUE")/RMPR7("QUANTITY")
S $P(R1(0),U,16)=RMPRCOST
S $P(R1(1),U,4)=RMDAHC
S $P(R1(0),U,14)=RMPR11I("SOURCE")
G VEN0
;
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) CO 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
..S RMCPOLD=RMCPT
..D CPT^RMPRCPTU(RDA) Q:$D(DUOUT)!$D(DUOUT) S $P(R1(1),U,6)=$G(RMCPT)
..W:RMCPOLD=RMCPT !!,"*** Based on the information given above, CPT Modifier string has not changed!!!",!
..W:RMCPOLD'=RMCPT !,"NEW CPT MODIFIER: ",$G(RMCPT)
K DIR
;
VEN0 ;process vendor
K DIC,DIR
S:$D(RMPR6("VENDOR")) DIC("B")=RMPR6("VENDOR")
S:'$D(RMPR6("VENDOR")) DIC("B")=$P(R1(0),U,9)
S DIC(0)="AEQM"
;S DIC("S")="I $D(RMPRVEN(+Y))"
S DIC("A")="VENDOR:"
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
;
SOURCE ;
K DIR S DIR(0)="660,12",DIR("B")=$P(R1(0),U,14),DIR("A")="SOURCE"
D ^DIR G:$D(DIRUT)!$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT^RMPRPIYF
S $P(R1(0),U,14)=Y,$P(R3("D"),U,14)=$S(Y="C":"Commercial",1:"VA")
;
QTY K DIR S DIR("A")="QUANTITY"
S DIR(0)="660,5",DIR("B")=$P(R1(0),U,7)
D ^DIR G:$D(DIRUT)!$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT^RMPRPIYF
I $D(RMUBA),((RMUBA+$P(R1(0),U,7))-Y<0) D LOWBA^RMPRPIYI G HCPCS^RMPRPIYE
S $P(R1(0),U,7)=Y K DIR
;
CP G ^RMPRPIYF
;
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",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 RMPRCOST=$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
S Y=$P(R1(1),U,8) G:Y="" CO D DD^%DT S $P(R1("D"),U,8)=Y
D ^RMPRPIYK G DEL
Q
;
SET60 ;
;RMPR60 -array of data fields for 660 file record.
S RMPR60("ISSUE TYPE")=$P(R1(0),U,4)
S RMPR60("IFCAP ITEM")=$P(R1(0),U,6)
S RMPR60("QUANTITY")=$P(R1(0),U,7)
S RMPR60("UNIT")=$P(R1(0),U,8)
S RMPR60("VENDOR IEN")=$P(R1(0),U,9)
S RMPR60("SERIAL NUM")=$P(R1(0),U,11)
S RMPR60("DELIV DATE")=$P(R1(0),U,12)
S RMPR60("DATE OF SERVICE")=$P(R1(1),U,8)
S RMPR60("SOURCE")=$P(R1(0),U,14)
S RMPR60("COST")=$P(R1(0),U,16)
S RMPR60("REMARKS")=$P(R1(0),U,18)
S RMPR60("LOT NUM")=$P(R1(0),U,24)
S RMPR60("CPT IEN")=$P(R1(0),U,22)
S RMPR60("USER")=$P(R1(0),U,27)
S RMPR60("CPT MOD")=$P(R1(1),U,6)
S RMPR60("HCPCS")=$P(R1(1),U,4)
S RMPR60("PAT CAT")=$P(R1("AM"),U,3)
S RMPR60("SPEC CAT")=$P(R1("AM"),U,4)
S RMPR60("VENDOR")=$P(R1(0),U,9)
S:$G(RMDAHC) RMPR60("HCPCS")=RMDAHC
;S:$D(RMPR11I("HCPCS")) RMPR60("HCPCS")=RMPR11I("HCPCS")
S:$D(RMPR11I("ITEM")) RMPR60("ITEM")=RMPR11I("ITEM")
S:$D(R1("DATE&TIME")) RMPR60("DATE&TIME")=R1("DATE&TIME")
S RMPR60("VALUE")=RMPR60("COST")
S:'$D(RMPR11I("STATION")) RMPR11I("STATION")=$G(RMPR("STA"))
S:$P(R1("AM"),U,3)'=4 RMPR60("SPEC CAT")="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYE 7552 printed Nov 22, 2024@17:47:02 Page 2
RMPRPIYE ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;3/8/05 08:04
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ; RVD #61 - phase III of PIP enhancement.
+3 ;DBIA #227 - Read access to .01 field of file #445.
+4 ;DBIA #800 - FILEMAN look up of file #440.
+5 ;
EN ;EDIT STOCK ISSUES
+1 KILL RMPR6,RMPR11,RMPR11I,RMPR5,RMPR7I,RMPR7,RMPR9,RMPR1
+2 DO HOME^%ZIS
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT^RMPRPIYF
+3 SET DIC("S")="S RM661=$G(^RMPR(660,+Y,1)) I ($P(^RMPR(660,+Y,0),U,13)=11),($P(^(0),U,10)=RMPR(""STA""))"
+4 ;I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
+5 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^RMPRPIYF
+6 SET RMPRIEN=+Y
+7 LOCK +^RMPR(660,+Y):1
IF $TEST=0
WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"
GOTO EXIT^RMPRPIYF
+8 SET (RMDFN,DFN)=$PIECE(^RMPR(660,+Y,0),U,2)
+9 SET RMPRF=$PIECE(^RMPR(660,+Y,0),U,13)
INVSE SET %X=DIC_+Y_","
SET %Y="R1("
DO %XY^%RCR
+1 SET %X=DIC_+Y_","
SET %Y="R1BCK("
DO %XY^%RCR
+2 if '$DATA(R1(2))
SET R1(2)=""
if '$DATA(R1BCK(2))
SET R1BCK(2)=""
+3 DO DEM^VADPT
+4 SET RMPRNAM=$PIECE(VADM(1),U)
SET RMPRSSN=$PIECE(VADM(2),U)
+5 SET (RMHCPC,RMHCNEW,RMHCOLD)=$PIECE($GET(R1(1)),U,4)
SET (RSTCK,REDIT)=1
SET RMPRCOST=0
+6 SET RMCPT=$PIECE(R1(1),U,6)
+7 SET (RMQNEW,RMQOLD)=$PIECE($GET(R1(0)),U,7)
+8 SET (RMLOCNEW,RMLOCOLD,RMITNEW,RMITOLD)=""
+9 SET RMSTOCK=$PIECE($GET(R1(1)),U,5)
+10 IF $GET(RMSTOCK)
SET R6612=$GET(^RMPR(661.6,RMSTOCK,0))
SET (RMLOC,RMLOCNEW,RMLOCOLD)=$PIECE(R6612,U,14)
SET (RMIT,RMITNEW,RMITOLD)=$PIECE(R1(2),U,1)
+11 SET R12(0)=R1(0)
SET RMPRREL=$PIECE(R1(0),U,16)
+12 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)
+13 KILL DIC
SET R3("D")=""
SET R4("D")=""
+14 GOTO SET
+15 ;
CO ;DISPLAYS STOCK ISSUE
+1 DO CHK^RMPRED5
+2 DO ^RMPRPIYK
+3 ;
EDX ;POST
+1 SET DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
+2 SET DIR("A")="Would 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^RMPRPIYF
if Y="D"
GOTO DEL1^RMPRPIYF
+4 if Y="E"
GOTO EDT
+5 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
GOTO EXIT^RMPRPIYF
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
+3 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT^RMPRPIYF
+4 IF Y="E"
GOTO EDT
+5 IF Y="D"
GOTO DEL1^RMPRPIYF
+6 ;
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",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",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 ;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: "
+1 ;
HCPCS ;scanning an item is mandatory.
+1 WRITE !
DO SCAN^RMPRPIYS
+2 IF $PIECE(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P"))
GOTO CO^RMPRPIYE
+3 IF RMPREXC="^"
GOTO CO^RMPRPIYE
+4 IF RMPREXC="P"
GOTO CO^RMPRPIYE
+5 IF RMPREXC="T"
GOTO CO^RMPRPIYE
+6 IF RMPRBARC=""
IF $GET(REDIT)
GOTO VEN0
+7 IF RMPRBARC=""
GOTO HCPCS
+8 DO HCPCS3^RMPRPIY1
+9 ;set ALL variables based on the scanned label
+10 SET $PIECE(R1(0),U,6)=$GET(RMPR11I("ITEM MASTER IEN"))
+11 SET RMPRCOST=0
+12 IF RMPR7("VALUE")>0
IF RMPR7("QUANTITY")>0
SET RMPRCOST=RMPR7("VALUE")/RMPR7("QUANTITY")
+13 SET $PIECE(R1(0),U,16)=RMPRCOST
+14 SET $PIECE(R1(1),U,4)=RMDAHC
+15 SET $PIECE(R1(0),U,14)=RMPR11I("SOURCE")
+16 GOTO VEN0
+17 ;
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 CO
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)
Begin DoDot:2
+9 SET RMCPOLD=RMCPT
+10 DO CPT^RMPRCPTU(RDA)
if $DATA(DUOUT)!$DATA(DUOUT)
QUIT
SET $PIECE(R1(1),U,6)=$GET(RMCPT)
+11 if RMCPOLD=RMCPT
WRITE !!,"*** Based on the information given above, CPT Modifier string has not changed!!!",!
+12 if RMCPOLD'=RMCPT
WRITE !,"NEW CPT MODIFIER: ",$GET(RMCPT)
End DoDot:2
End DoDot:1
+13 KILL DIR
+14 ;
VEN0 ;process vendor
+1 KILL DIC,DIR
+2 if $DATA(RMPR6("VENDOR"))
SET DIC("B")=RMPR6("VENDOR")
+3 if '$DATA(RMPR6("VENDOR"))
SET DIC("B")=$PIECE(R1(0),U,9)
+4 SET DIC(0)="AEQM"
+5 ;S DIC("S")="I $D(RMPRVEN(+Y))"
+6 SET DIC("A")="VENDOR:"
+7 SET DIC="^PRC(440,"
SET DIC(0)="AEQM"
DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CO
+8 if +Y<0
GOTO VEN0
+9 SET $PIECE(R1(0),U,9)=+Y
SET $PIECE(R3("D"),U,9)=$PIECE(Y,U,2)
KILL DIR,DIC
+10 ;
SOURCE ;
+1 KILL DIR
SET DIR(0)="660,12"
SET DIR("B")=$PIECE(R1(0),U,14)
SET DIR("A")="SOURCE"
+2 DO ^DIR
if $DATA(DIRUT)!$DATA(DUOUT)
GOTO CO^RMPRPIYE
if $DATA(DTOUT)
GOTO EXIT^RMPRPIYF
+3 SET $PIECE(R1(0),U,14)=Y
SET $PIECE(R3("D"),U,14)=$SELECT(Y="C":"Commercial",1:"VA")
+4 ;
QTY KILL DIR
SET DIR("A")="QUANTITY"
+1 SET DIR(0)="660,5"
SET DIR("B")=$PIECE(R1(0),U,7)
+2 DO ^DIR
if $DATA(DIRUT)!$DATA(DUOUT)
GOTO CO^RMPRPIYE
if $DATA(DTOUT)
GOTO EXIT^RMPRPIYF
+3 IF $DATA(RMUBA)
IF ((RMUBA+$PIECE(R1(0),U,7))-Y<0)
DO LOWBA^RMPRPIYI
GOTO HCPCS^RMPRPIYE
+4 SET $PIECE(R1(0),U,7)=Y
KILL DIR
+5 ;
CP GOTO ^RMPRPIYF
+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",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 RMPRCOST=$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 SET Y=$PIECE(R1(1),U,8)
if Y=""
GOTO CO
DO DD^%DT
SET $PIECE(R1("D"),U,8)=Y
+10 DO ^RMPRPIYK
GOTO DEL
+11 QUIT
+12 ;
SET60 ;
+1 ;RMPR60 -array of data fields for 660 file record.
+2 SET RMPR60("ISSUE TYPE")=$PIECE(R1(0),U,4)
+3 SET RMPR60("IFCAP ITEM")=$PIECE(R1(0),U,6)
+4 SET RMPR60("QUANTITY")=$PIECE(R1(0),U,7)
+5 SET RMPR60("UNIT")=$PIECE(R1(0),U,8)
+6 SET RMPR60("VENDOR IEN")=$PIECE(R1(0),U,9)
+7 SET RMPR60("SERIAL NUM")=$PIECE(R1(0),U,11)
+8 SET RMPR60("DELIV DATE")=$PIECE(R1(0),U,12)
+9 SET RMPR60("DATE OF SERVICE")=$PIECE(R1(1),U,8)
+10 SET RMPR60("SOURCE")=$PIECE(R1(0),U,14)
+11 SET RMPR60("COST")=$PIECE(R1(0),U,16)
+12 SET RMPR60("REMARKS")=$PIECE(R1(0),U,18)
+13 SET RMPR60("LOT NUM")=$PIECE(R1(0),U,24)
+14 SET RMPR60("CPT IEN")=$PIECE(R1(0),U,22)
+15 SET RMPR60("USER")=$PIECE(R1(0),U,27)
+16 SET RMPR60("CPT MOD")=$PIECE(R1(1),U,6)
+17 SET RMPR60("HCPCS")=$PIECE(R1(1),U,4)
+18 SET RMPR60("PAT CAT")=$PIECE(R1("AM"),U,3)
+19 SET RMPR60("SPEC CAT")=$PIECE(R1("AM"),U,4)
+20 SET RMPR60("VENDOR")=$PIECE(R1(0),U,9)
+21 if $GET(RMDAHC)
SET RMPR60("HCPCS")=RMDAHC
+22 ;S:$D(RMPR11I("HCPCS")) RMPR60("HCPCS")=RMPR11I("HCPCS")
+23 if $DATA(RMPR11I("ITEM"))
SET RMPR60("ITEM")=RMPR11I("ITEM")
+24 if $DATA(R1("DATE&TIME"))
SET RMPR60("DATE&TIME")=R1("DATE&TIME")
+25 SET RMPR60("VALUE")=RMPR60("COST")
+26 if '$DATA(RMPR11I("STATION"))
SET RMPR11I("STATION")=$GET(RMPR("STA"))
+27 if $PIECE(R1("AM"),U,3)'=4
SET RMPR60("SPEC CAT")="@"
+28 QUIT
