RMPRP21 ;PHX/RFM-PRINT 10-2421 ;8/29/1994
;;3.0;PROSTHETICS;**3,19,55,90,129,133,139,153**;Feb 09, 1996;Build 10
;
; ODJ - patch 55 - 1/29/01 - extrinsic to get mail routing code
; from site param. replaces hard code 121
; nois AUG-1097-32118
;
I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT Q:$D(X)
I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT
I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS
EN ;ENTRY POINT FOR REPRINTING A 10-2421 FORM
I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EX
S RMPRACT=1,DIC="^RMPR(664,",DIC(0)="AEQM",DIC("A")="Select Transaction or Patient Name: ",RMPRF=2
S DIC("S")="I $D(^RMPR(664,Y,1)) S RZZZ=$O(^RMPR(664,Y,1,0)) I RZZZ S RX=$P(^(RZZZ,0),U,13) S:$D(^RMPR(660,+RX,0)) RX=$P(^(0),U,13) I RX=2,'$D(^RMPR(664,""AP"",RMPR(""STA""),Y))"
S DIC("W")="D EN2^RMPRD1" D ^DIC G:Y<0 EX S RMPRA=+Y I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM
D PR^RMPR21A I %'>0 G EX
I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1),%ZIS="Q" D ^%ZIS G:POP EX S ZTIO=ION G PT
ZIS S %ZIS="QM" D ^%ZIS G:POP EX
I '$D(IO("Q")) U IO G PRT
S ZTIO=ION
PT S ZTDTH=$H,ZTSAVE("RMPRPN")="",ZTSAVE("RMPRA")="",ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")="",ZTRTN="PRT^RMPRP21",ZTDESC="2421 FORM"
S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")="" D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED>",1:"<REQUEST NOT QUEUED>") D HOME^%ZIS H 3 G EX
PRT ;ENTRY POINT TO PRINT 2421S
S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y
S RDUZ=$P(R664(0),U,9),RDUZ=$P(^VA(200,RDUZ,0),U,1),DFN=$P(R664(0),U,2),RTN=$P(R664(0),U,7),CP=$P(R664(0),U,6),CP=$P($G(^PRCS(410,CP,0)),U,1),RMPRPAGE=2
D ADD^VADPT,DEM^VADPT,ELIG^VADPT
W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: "
W !,"By receiving this purchase order you agree to take appropriate measures to"
W !,"secure the information and ensure the confidentiality of the patient information"
W !,"is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW"
HDR ;PRINT HEADER FOR 2421 ADDRESS INFO
I $P($G(R664(4)),U,8) W !,?30,"***WORKING COPY***"
S (RMPRT,RMPRB)="",$P(RMPRT,"_",IOM)="",$P(RMPRB,"-",IOM)="" W !,RMPRT,!,"Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services",!,RMPRB
W !,"1. Name and Address of Vendor",?40,"2. Name and Address of VA Facility"
S RMPRV=$P(R664(0),U,4),RMPRST=""
I $D(^PRC(440,RMPRV,0)) S RMPRV=^PRC(440,RMPRV,0) D
.S RMPRST=$P(RMPRV,U,7),RMPRPHON=$P(RMPRV,U,10)
.S RMPRAD1=$P(RMPRV,U,2),RMPRAD2=$P(RMPRV,U,3)
.S RMPRCITY=$P(RMPRV,U,6),RMPR90IP=$P(RMPRV,U,8)
.S RMPRVACN=$P($G(^PRC(440,$P(R664(0),U,4),2)),U,1)
I $D(^DIC(5,+RMPRST,0)) S RMPRST=$P(^(0),U,2)
E S RMPRST="NO STATE ON FILE"
W !,?5,$E($P(RMPRV,U,1),1,30),?40
W $E(RMPR("NAME"),1,28)," ","(",$$STA^RMPRUTIL,"/",$$ROU^RMPRUTIL(RMPRSITE),")"
W !,?5,$E(RMPRAD1,1,35),?40,$E(RMPR("ADD"),1,39)
I RMPRAD2'="" W !,?5,$E(RMPRAD2,1,35),?40,RMPR("CITY")
I RMPRAD2="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP,?40,RMPR("CITY")
I RMPRAD2'="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP
W !,?5,RMPRPHON
;W:$G(RMPRVACN)'="" ?22,"ACCT # ",RMPRVACN
W ?40,$P(^RMPR(669.9,RMPRSITE,0),U,4),!,RMPRB
W !,"3. Veterans Name (Last, First, MI)",?40,"4. Date of Authorization"
W !,?5,VADM(1) S Y=$P(R664(0),U,1) D DD^%DT W ?45,Y
I $D(RMPRMOR) W !,RMPRB D HDR1 Q
W !,RMPRB S RMPRODTE=Y
S RMPRDELD="" I $D(R664(3)),$P(R664(3),U,2)]"" S Y=$P(R664(3),U,2) D DD^%DT S RMPRDELD=Y
W !,"5. Veterans Address",?40,"6. Date Required",!,?5,VAPA(1),?45,RMPRDELD,!
I VAPA(2)="" W ?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,$E(RMPRB,1,40),!,?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION"
I VAPA(2)'="" W ?5,VAPA(2),?40,$E(RMPRB,1,40),!,?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION"
W !,RMPRB
W !,"7. Claim Number",?40,"8. SSN",!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time"
S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10)
S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") S SPE=$P(R664(1,R664("E"),0),U,11)
S RMPRSCAT=$S(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"")
W !,RMPRCAT_" "_RMPRSCAT S:+$P(R664(0),U,10) RMPRFOB=$P(R664(0),U,10) W ?34,$S($D(RMPRFOB):"ORIGIN",1:"DEST"),?49,"% " I $D(R664(2)) W $P(R664(2),U,6)
I $D(R664(3)) W ?66,$P(R664(3),U,3)_" Days"
W !,?30,$E(RMPRB,1,50),!,?30,"14. Delivery To: " W:$D(R664(3)) $P(R664(3),U) W !,RMPRB
HDR1 ;HEADER FOR 10-2421
W !?17,"15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED",!,RMPRB,!,"ITEM NUMBER",?23,"DESCRIPTION/NOMENCLATURE",?50,"QUANTITY",?60,"UNIT",?66,"UNIT",?73,"AMOUNT",!,?50,"ORDERED",?66,"PRICE",!,RMPRB Q:$D(RMPRMOR)
D ^RMPRP22 D:'$D(RMPRMOR1) CON^RMPRP22
S RMPRK=RMPRA
D:$D(RMPRPRIV) ^RMPRP23
W:$G(RMPRPN)=1 @IOF,$$EN^RMPRP24(RMPRK)
EX ;KILL VARIABLES AND EXIT ROUTINE
K VADM,CP,DFN,CAT,DIC,R664,RMPRA,RMPACT,RMPRAD1,RMPRAD2,RMPRAMT,RMPRAMT1,RMPRB,RMPRCAT,RMPRCH,RMPRCITY,RMPRDELD,RMPRI,RMPRI1,RMPRIT,RMPRN,RMPRODTE,RMPRST,RMPRPHON,RMPRT,RMPRTOT,RMPRUT,RMPRV,RMPR90IP,RO,RP,J1,RTN,RMPRMOR1,RMPRPRIV
K SPE,VA,VAEL,VAPA,VAERR,RZZZ,RX,RX1,RDUZ,RC,RMPRACT,RMPRSCAT,RMPRDISC,RMPRAMTN,DIR,DIRUT,RMPRAMT2,RMPRFOB,RMPRDA,RMPRMOR,RMPRPAGE,RMPRPRIV,RMPRX,RMPR90,J,K,N D ^%ZISC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRP21 5579 printed Oct 16, 2024@18:36:06 Page 2
RMPRP21 ;PHX/RFM-PRINT 10-2421 ;8/29/1994
+1 ;;3.0;PROSTHETICS;**3,19,55,90,129,133,139,153**;Feb 09, 1996;Build 10
+2 ;
+3 ; ODJ - patch 55 - 1/29/01 - extrinsic to get mail routing code
+4 ; from site param. replaces hard code 121
+5 ; nois AUG-1097-32118
+6 ;
+7 IF '$DATA(RMPR)!'$DATA(RMPRSITE)
DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+8 IF +$PIECE(^RMPR(669.9,RMPRSITE,0),U,5)
IF $DATA(RMPRA)&($DATA(^%ZIS(1,$PIECE(^RMPR(669.9,RMPRSITE,0),U,5),0)))
SET IOP="Q;"_$PIECE(^(0),U,1)
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EX
SET ZTIO=ION
GOTO PT
+9 IF $DATA(RMPRA)&('$PIECE(^RMPR(669.9,RMPRSITE,0),U,5))
GOTO ZIS
EN ;ENTRY POINT FOR REPRINTING A 10-2421 FORM
+1 IF '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EX
+2 SET RMPRACT=1
SET DIC="^RMPR(664,"
SET DIC(0)="AEQM"
SET DIC("A")="Select Transaction or Patient Name: "
SET RMPRF=2
+3 SET DIC("S")="I $D(^RMPR(664,Y,1)) S RZZZ=$O(^RMPR(664,Y,1,0)) I RZZZ S RX=$P(^(RZZZ,0),U,13) S:$D(^RMPR(660,+RX,0)) RX=$P(^(0),U,13) I RX=2,'$D(^RMPR(664,""AP"",RMPR(""STA""),Y))"
+4 SET DIC("W")="D EN2^RMPRD1"
DO ^DIC
if Y<0
GOTO EX
SET RMPRA=+Y
IF $PIECE(^RMPR(664,+Y,0),U,5)
DO M2^RMPRM
+5 DO PR^RMPR21A
IF %'>0
GOTO EX
+6 IF +$PIECE(^RMPR(669.9,RMPRSITE,0),U,5)
IF $DATA(RMPRA)&($DATA(^%ZIS(1,$PIECE(^RMPR(669.9,RMPRSITE,0),U,5),0)))
SET IOP="Q;"_$PIECE(^(0),U,1)
SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EX
SET ZTIO=ION
GOTO PT
ZIS SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EX
+1 IF '$DATA(IO("Q"))
USE IO
GOTO PRT
+2 SET ZTIO=ION
PT SET ZTDTH=$HOROLOG
SET ZTSAVE("RMPRPN")=""
SET ZTSAVE("RMPRA")=""
SET ZTSAVE("RMPRSITE")=""
SET ZTSAVE("RMPR(")=""
SET ZTRTN="PRT^RMPRP21"
SET ZTDESC="2421 FORM"
+1 if $DATA(RMPRPRIV)
SET ZTSAVE("RMPRPRIV")=""
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"<REQUEST QUEUED>",1:"<REQUEST NOT QUEUED>")
DO HOME^%ZIS
HANG 3
GOTO EX
PRT ;ENTRY POINT TO PRINT 2421S
+1 SET %X="^RMPR(664,RMPRA,"
SET %Y="R664("
DO %XY^%RCR
KILL %X,%Y
+2 SET RDUZ=$PIECE(R664(0),U,9)
SET RDUZ=$PIECE(^VA(200,RDUZ,0),U,1)
SET DFN=$PIECE(R664(0),U,2)
SET RTN=$PIECE(R664(0),U,7)
SET CP=$PIECE(R664(0),U,6)
SET CP=$PIECE($GET(^PRCS(410,CP,0)),U,1)
SET RMPRPAGE=2
+3 DO ADD^VADPT
DO DEM^VADPT
DO ELIG^VADPT
+4 if $Y>0
WRITE @IOF
WRITE ?20,"OMB Number 2900-0188",?50,"PO#: "
+5 WRITE !,"By receiving this purchase order you agree to take appropriate measures to"
+6 WRITE !,"secure the information and ensure the confidentiality of the patient information"
+7 WRITE !,"is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW"
HDR ;PRINT HEADER FOR 2421 ADDRESS INFO
+1 IF $PIECE($GET(R664(4)),U,8)
WRITE !,?30,"***WORKING COPY***"
+2 SET (RMPRT,RMPRB)=""
SET $PIECE(RMPRT,"_",IOM)=""
SET $PIECE(RMPRB,"-",IOM)=""
WRITE !,RMPRT,!,"Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services",!,RMPRB
+3 WRITE !,"1. Name and Address of Vendor",?40,"2. Name and Address of VA Facility"
+4 SET RMPRV=$PIECE(R664(0),U,4)
SET RMPRST=""
+5 IF $DATA(^PRC(440,RMPRV,0))
SET RMPRV=^PRC(440,RMPRV,0)
Begin DoDot:1
+6 SET RMPRST=$PIECE(RMPRV,U,7)
SET RMPRPHON=$PIECE(RMPRV,U,10)
+7 SET RMPRAD1=$PIECE(RMPRV,U,2)
SET RMPRAD2=$PIECE(RMPRV,U,3)
+8 SET RMPRCITY=$PIECE(RMPRV,U,6)
SET RMPR90IP=$PIECE(RMPRV,U,8)
+9 SET RMPRVACN=$PIECE($GET(^PRC(440,$PIECE(R664(0),U,4),2)),U,1)
End DoDot:1
+10 IF $DATA(^DIC(5,+RMPRST,0))
SET RMPRST=$PIECE(^(0),U,2)
+11 IF '$TEST
SET RMPRST="NO STATE ON FILE"
+12 WRITE !,?5,$EXTRACT($PIECE(RMPRV,U,1),1,30),?40
+13 WRITE $EXTRACT(RMPR("NAME"),1,28)," ","(",$$STA^RMPRUTIL,"/",$$ROU^RMPRUTIL(RMPRSITE),")"
+14 WRITE !,?5,$EXTRACT(RMPRAD1,1,35),?40,$EXTRACT(RMPR("ADD"),1,39)
+15 IF RMPRAD2'=""
WRITE !,?5,$EXTRACT(RMPRAD2,1,35),?40,RMPR("CITY")
+16 IF RMPRAD2=""
WRITE !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP,?40,RMPR("CITY")
+17 IF RMPRAD2'=""
WRITE !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP
+18 WRITE !,?5,RMPRPHON
+19 ;W:$G(RMPRVACN)'="" ?22,"ACCT # ",RMPRVACN
+20 WRITE ?40,$PIECE(^RMPR(669.9,RMPRSITE,0),U,4),!,RMPRB
+21 WRITE !,"3. Veterans Name (Last, First, MI)",?40,"4. Date of Authorization"
+22 WRITE !,?5,VADM(1)
SET Y=$PIECE(R664(0),U,1)
DO DD^%DT
WRITE ?45,Y
+23 IF $DATA(RMPRMOR)
WRITE !,RMPRB
DO HDR1
QUIT
+24 WRITE !,RMPRB
SET RMPRODTE=Y
+25 SET RMPRDELD=""
IF $DATA(R664(3))
IF $PIECE(R664(3),U,2)]""
SET Y=$PIECE(R664(3),U,2)
DO DD^%DT
SET RMPRDELD=Y
+26 WRITE !,"5. Veterans Address",?40,"6. Date Required",!,?5,VAPA(1),?45,RMPRDELD,!
+27 IF VAPA(2)=""
WRITE ?5,VAPA(4)_","_$PIECE(VAPA(5),U,2)_" "_VAPA(6),?40,$EXTRACT(RMPRB,1,40),!,?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION"
+28 IF VAPA(2)'=""
WRITE ?5,VAPA(2),?40,$EXTRACT(RMPRB,1,40),!,?5,VAPA(4)_","_$PIECE(VAPA(5),U,2)_" "_VAPA(6),?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION"
+29 WRITE !,RMPRB
+30 WRITE !,"7. Claim Number",?40,"8. SSN",!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time"
+31 SET R664("E")=$ORDER(R664(1,0))
SET CAT=$PIECE(R664(1,R664("E"),0),U,10)
+32 SET RMPRCAT=$SELECT(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"")
SET SPE=$PIECE(R664(1,R664("E"),0),U,11)
+33 SET RMPRSCAT=$SELECT(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"")
+34 WRITE !,RMPRCAT_" "_RMPRSCAT
if +$PIECE(R664(0),U,10)
SET RMPRFOB=$PIECE(R664(0),U,10)
WRITE ?34,$SELECT($DATA(RMPRFOB):"ORIGIN",1:"DEST"),?49,"% "
IF $DATA(R664(2))
WRITE $PIECE(R664(2),U,6)
+35 IF $DATA(R664(3))
WRITE ?66,$PIECE(R664(3),U,3)_" Days"
+36 WRITE !,?30,$EXTRACT(RMPRB,1,50),!,?30,"14. Delivery To: "
if $DATA(R664(3))
WRITE $PIECE(R664(3),U)
WRITE !,RMPRB
HDR1 ;HEADER FOR 10-2421
+1 WRITE !?17,"15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED",!,RMPRB,!,"ITEM NUMBER",?23,"DESCRIPTION/NOMENCLATURE",?50,"QUANTITY",?60,"UNIT",?66,"UNIT",?73,"AMOUNT",!,?50,"ORDERED",?66,"PRICE",!,RMPRB
if $DATA(RMPRMOR)
QUIT
+2 DO ^RMPRP22
if '$DATA(RMPRMOR1)
DO CON^RMPRP22
+3 SET RMPRK=RMPRA
+4 if $DATA(RMPRPRIV)
DO ^RMPRP23
+5 if $GET(RMPRPN)=1
WRITE @IOF,$$EN^RMPRP24(RMPRK)
EX ;KILL VARIABLES AND EXIT ROUTINE
+1 KILL VADM,CP,DFN,CAT,DIC,R664,RMPRA,RMPACT,RMPRAD1,RMPRAD2,RMPRAMT,RMPRAMT1,RMPRB,RMPRCAT,RMPRCH,RMPRCITY,RMPRDELD,RMPRI,RMPRI1,RMPRIT,RMPRN,RMPRODTE,RMPRST,RMPRPHON,RMPRT,RMPRTOT,RMPRUT,RMPRV,RMPR90IP,RO,RP,J1,RTN,RMPRMOR1,RMPRPRIV
+2 KILL SPE,VA,VAEL,VAPA,VAERR,RZZZ,RX,RX1,RDUZ,RC,RMPRACT,RMPRSCAT,RMPRDISC,RMPRAMTN,DIR,DIRUT,RMPRAMT2,RMPRFOB,RMPRDA,RMPRMOR,RMPRPAGE,RMPRPRIV,RMPRX,RMPR90,J,K,N
DO ^%ZISC
QUIT
