- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P21.m
r613 r623 1 RMPR4P21 ;PHX/HNC,RVD -PRINT PURCHASE CARD ORDER ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,15,19,26,55,90,132,133,139**;Feb 09, 1996;Build 4 3 ; 4 ; ODJ - patch 55 - 1/29/01 - replace hard code mail route symbol 121 5 ; with extrinsic call to read site param. 6 ; (nois AUG-1097-32118) 7 ; 8 G:$D(RMPRA)&($G(RMPRA)'>0) EN I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT G:$D(X) EX 9 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 10 I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS 11 EN1(RMPRPTR) ; 12 I $D(RMPRPTR) I $D(RMPRA)&($D(^%ZIS(1,RMPRPTR,0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT 13 EN ;ENTRY POINT FOR REPRINTING- Modified in patch 90 HNC 14 I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT G:$D(X) EX 15 S RMPRACT=1,DIC="^RMPR(664,",DIC(0)="AEQM",DIC("A")="Select Transaction or Patient Name: ",RMPRF=2 16 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 17 S DIC("W")="D EN2^RMPR4D1" 18 D ^DIC G:Y<0 EX 19 S RMPRA=+Y 20 ;I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM 21 D PR^RMPR421A I %'>0 G EX 22 ;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 23 ZIS S %ZIS="QM" D ^%ZIS G:POP EX 24 I '$D(IO("Q")) U IO G PRT 25 S ZTIO=ION 26 PT S ZTDTH=$H,ZTSAVE("RMPRPN")="",ZTSAVE("RMPRA")="",ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")="",ZTRTN="PRT^RMPR4P21",ZTDESC="PURCHASE CARD ORDER" 27 S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")="" D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED>",1:"<REQUEST NOT QUEUED>") D HOME^%ZIS H 3 G EX 28 PRT ;ENTRY POINT TO PRINT 29 S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y 30 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),RMPRPAGE=2 31 D ADD^VADPT,DEM^VADPT,ELIG^VADPT 32 W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: ",$P($G(^RMPR(664,RMPRA,4)),U,5) 33 W !,"By receiving this purchase order you agree to take appropriate measures to" 34 W !,"secure the information and ensure the confidentiality of the patient information" 35 W !,"is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW" 36 HDR ;PRINT HEADER FOR 2421 ADDRESS INFO 37 S (RMPRT,RMPRB)="",$P(RMPRT,"_",IOM)="",$P(RMPRB,"-",IOM)="" W !,RMPRT,!,"Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services",!,RMPRB 38 W !,"1. Name and Address of Vendor",?40,"2. Name and Address of VA Facility" 39 S RMPRV=$P(R664(0),U,4),RMPRST="" 40 I $D(^PRC(440,RMPRV,0)) S RMPRV=^PRC(440,RMPRV,0) D 41 .S RMPRST=$P(RMPRV,U,7),RMPRPHON=$P(RMPRV,U,10) 42 .S RMPRAD1=$P(RMPRV,U,2),RMPRAD2=$P(RMPRV,U,3) 43 .S RMPRCITY=$P(RMPRV,U,6),RMPR90IP=$P(RMPRV,U,8) 44 .S RMPRVACN=$P($G(^PRC(440,$P(R664(0),U,4),2)),U,1) 45 I $D(^DIC(5,+RMPRST,0)) S RMPRST=$P(^(0),U,2) 46 E S RMPRST="NO STATE ON FILE" 47 W !,?5,$E($P(RMPRV,U,1),1,30),?40 48 W $E(RMPR("NAME"),1,28)," ","(",$$STA^RMPRUTIL,"/",$$ROU^RMPRUTIL(RMPRSITE),")" 49 W !,?5,$E(RMPRAD1,1,35),?40,$E(RMPR("ADD"),1,39) 50 I RMPRAD2'="" W !,?5,$E(RMPRAD2,1,35),?40,RMPR("CITY") 51 I RMPRAD2="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP,?40,RMPR("CITY") 52 I RMPRAD2'="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP 53 W !,?5,RMPRPHON 54 ;W:$G(RMPRVACN)'="" ?22,"ACCT # ",RMPRVACN 55 W ?40,$P(^RMPR(669.9,RMPRSITE,0),U,4),!,RMPRB 56 W !,"3. Veterans Name (Last, First, MI)",?40,"4. Date of Authorization" 57 W !,?5,VADM(1) S Y=$P(R664(0),U,1) D DD^%DT W ?45,Y 58 I $D(RMPRMOR) W !,RMPRB D HDR1 Q 59 W !,RMPRB S RMPRODTE=Y 60 S RMPRDELD="" I $D(R664(3)),$P(R664(3),U,2)]"" S Y=$P(R664(3),U,2) D DD^%DT S RMPRDELD=Y 61 W !,"5. Veterans Address",?40,"6. Date Required",!,?5,VAPA(1),?45,RMPRDELD,! 62 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" 63 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" 64 W !,RMPRB 65 ;Remove claim number print in *139 since it held SSN at times 66 W !,"7. Claim Number",?40,"8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time" 67 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 68 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") 69 S SPE=$P(R664(1,R664("E"),0),U,11) 70 S RMPRSCAT=$S(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"") 71 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) 72 I $D(R664(3)) W ?66,$P(R664(3),U,3)_" Days" 73 W !,?30,$E(RMPRB,1,50),!,?30,"14. Delivery To: " W:$D(R664(3)) $P(R664(3),U) 74 W !,?36,"Attention: "_$P(R664(3),U,4) W !,RMPRB 75 HDR1 ;HEADER FOR 10-2421 76 W !?17,"15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED",!,RMPRB,!,"ITEM NUMBER",?23,"DESCRIPTION",?50,"QUANTITY",?60,"UNIT",?66,"UNIT",?73,"AMOUNT",!,?50,"ORDERED",?66,"PRICE",!,RMPRB Q:$D(RMPRMOR) 77 D ^RMPR4P22 D:'$D(RMPRMOR1) CON^RMPR4P22 78 S RMPRK=RMPRA 79 D:$D(RMPRPRIV) ^RMPR4P23 80 W:$G(RMPRPN)=1 @IOF,$$EN^RMPR4P24(RMPRK) 81 EX ;Common Exit Point 82 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 83 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 1 RMPR4P21 ;PHX/HNC,RVD -PRINT PURCHASE CARD ORDER ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,15,19,26,55,90,132,133**;Feb 09, 1996;Build 2 3 ; 4 ; ODJ - patch 55 - 1/29/01 - replace hard code mail route symbol 121 5 ; with extrinsic call to read site param. 6 ; (nois AUG-1097-32118) 7 ; 8 G:$D(RMPRA)&($G(RMPRA)'>0) EN I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT G:$D(X) EX 9 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 10 I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS 11 EN1(RMPRPTR) ; 12 I $D(RMPRPTR) I $D(RMPRA)&($D(^%ZIS(1,RMPRPTR,0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT 13 EN ;ENTRY POINT FOR REPRINTING- Modified in patch 90 HNC 14 I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT G:$D(X) EX 15 S RMPRACT=1,DIC="^RMPR(664,",DIC(0)="AEQM",DIC("A")="Select Transaction or Patient Name: ",RMPRF=2 16 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 17 S DIC("W")="D EN2^RMPR4D1" 18 D ^DIC G:Y<0 EX 19 S RMPRA=+Y 20 ;I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM 21 D PR^RMPR421A I %'>0 G EX 22 ;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 23 ZIS S %ZIS="QM" D ^%ZIS G:POP EX 24 I '$D(IO("Q")) U IO G PRT 25 S ZTIO=ION 26 PT S ZTDTH=$H,ZTSAVE("RMPRPN")="",ZTSAVE("RMPRA")="",ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")="",ZTRTN="PRT^RMPR4P21",ZTDESC="PURCHASE CARD ORDER" 27 S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")="" D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED>",1:"<REQUEST NOT QUEUED>") D HOME^%ZIS H 3 G EX 28 PRT ;ENTRY POINT TO PRINT 29 S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y 30 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),RMPRPAGE=2 31 D ADD^VADPT,DEM^VADPT,ELIG^VADPT 32 W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: ",$P($G(^RMPR(664,RMPRA,4)),U,5) 33 W !,"By receiving this purchase order you agree to take appropriate measures to" 34 W !,"secure the information and ensure the confidentiality of the patient information" 35 W !,"is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW" 36 HDR ;PRINT HEADER FOR 2421 ADDRESS INFO 37 S (RMPRT,RMPRB)="",$P(RMPRT,"_",IOM)="",$P(RMPRB,"-",IOM)="" W !,RMPRT,!,"Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services",!,RMPRB 38 W !,"1. Name and Address of Vendor",?40,"2. Name and Address of VA Facility" 39 S RMPRV=$P(R664(0),U,4),RMPRST="" 40 I $D(^PRC(440,RMPRV,0)) S RMPRV=^PRC(440,RMPRV,0) D 41 .S RMPRST=$P(RMPRV,U,7),RMPRPHON=$P(RMPRV,U,10) 42 .S RMPRAD1=$P(RMPRV,U,2),RMPRAD2=$P(RMPRV,U,3) 43 .S RMPRCITY=$P(RMPRV,U,6),RMPR90IP=$P(RMPRV,U,8) 44 .S RMPRVACN=$P($G(^PRC(440,$P(R664(0),U,4),2)),U,1) 45 I $D(^DIC(5,+RMPRST,0)) S RMPRST=$P(^(0),U,2) 46 E S RMPRST="NO STATE ON FILE" 47 W !,?5,$E($P(RMPRV,U,1),1,30),?40 48 W $E(RMPR("NAME"),1,28)," ","(",$$STA^RMPRUTIL,"/",$$ROU^RMPRUTIL(RMPRSITE),")" 49 W !,?5,$E(RMPRAD1,1,35),?40,$E(RMPR("ADD"),1,39) 50 I RMPRAD2'="" W !,?5,$E(RMPRAD2,1,35),?40,RMPR("CITY") 51 I RMPRAD2="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP,?40,RMPR("CITY") 52 I RMPRAD2'="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP 53 W !,?5,RMPRPHON 54 ;W:$G(RMPRVACN)'="" ?22,"ACCT # ",RMPRVACN 55 W ?40,$P(^RMPR(669.9,RMPRSITE,0),U,4),!,RMPRB 56 W !,"3. Veterans Name (Last, First, MI)",?40,"4. Date of Authorization" 57 W !,?5,VADM(1) S Y=$P(R664(0),U,1) D DD^%DT W ?45,Y 58 I $D(RMPRMOR) W !,RMPRB D HDR1 Q 59 W !,RMPRB S RMPRODTE=Y 60 S RMPRDELD="" I $D(R664(3)),$P(R664(3),U,2)]"" S Y=$P(R664(3),U,2) D DD^%DT S RMPRDELD=Y 61 W !,"5. Veterans Address",?40,"6. Date Required",!,?5,VAPA(1),?45,RMPRDELD,! 62 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" 63 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" 64 W !,RMPRB 65 W !,"7. Claim Number"_" "_VAEL(7),?40,"8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time" 66 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 67 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") 68 S SPE=$P(R664(1,R664("E"),0),U,11) 69 S RMPRSCAT=$S(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"") 70 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) 71 I $D(R664(3)) W ?66,$P(R664(3),U,3)_" Days" 72 W !,?30,$E(RMPRB,1,50),!,?30,"14. Delivery To: " W:$D(R664(3)) $P(R664(3),U) 73 W !,?36,"Attention: "_$P(R664(3),U,4) W !,RMPRB 74 HDR1 ;HEADER FOR 10-2421 75 W !?17,"15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED",!,RMPRB,!,"ITEM NUMBER",?23,"DESCRIPTION",?50,"QUANTITY",?60,"UNIT",?66,"UNIT",?73,"AMOUNT",!,?50,"ORDERED",?66,"PRICE",!,RMPRB Q:$D(RMPRMOR) 76 D ^RMPR4P22 D:'$D(RMPRMOR1) CON^RMPR4P22 77 S RMPRK=RMPRA 78 D:$D(RMPRPRIV) ^RMPR4P23 79 W:$G(RMPRPN)=1 @IOF,$$EN^RMPR4P24(RMPRK) 80 EX ;Common Exit Point 81 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 82 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
Note:
See TracChangeset
for help on using the changeset viewer.
