- 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/RMPRPRT1.m
r613 r623 1 RMPRPRT1 ;PHX/HNB-CONTINUATION OF PRINT 2319 ;10/19/1993 2 ;;3.0;PROSTHETICS;**10,99,137,141**;Feb 09, 1996;Build 5 3 ;CALLED BY END^RMPRPRT 4 ;VARIABLES REQUIRED: R5 - A STRING ARRAY HOLDING PATIENT'S PROSTHETIC 5 ; DISABILITY CODE INFORMATION 6 N RMPRMERG S RMPRMERG=0 7 I $D(^XDRM("B",RMPRDFN_";DPT(")) D 8 . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG="" 9 . S RMPRMERG=+^XDRM(RMPRMERG,0) 10 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 11 W !!,"PSC Issue Card: " S J=0 W ! 12 F I=1:1 D Q:J'>0 13 .I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 14 .S J=$O(R5(5,J)) Q:J=""!(J?.A) Q:$G(J)<1 15 .S L=$P(R5(5,J,0),U,1) ;S L=$P(R5(5,J,0),U,1) 16 .W $E(L,4,5)_"-"_$E(L,6,7)_"-"_$E(L,2,3),?17,"Appl: ",$S($D(^RMPR(661,+$P(R5(5,J,0),U,4),0)):$E($P(^PRC(441,+$P(^(0),U),0),U,2),1,37),1:"UNKNOWN"),?66,"SN: ",$P(R5(5,J,0),U,3),! 17 I I=1 W "NONE LISTED",! 18 W !,"Clothing Allowance: ",! 19 I $D(R5(6)),$O(R5(6,0))>0 D 20 .F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,6,"B",RI)) Q:RI'>0 D 21 ..S RA=$O(^RMPR(665,RMPRDFN,6,"B",RI,0)) 22 ..S RR5=R5(6,RA,0),RR5=RR5 23 ..;D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 24 ..W ?22,"DATE: ",$E(RR5,4,5)_"-"_$E(RR5,6,7)_"-"_$E(RR5,2,3) 25 ..W " ",$S($P(RR5,U,2)["E":"ELIGIBLE",$P(RR5,U,2)["N":"NOT-ELIGIBLE",1:"") 26 ..W " ",$S($P(RR5,U,3)["S":"STATIC",$P(RR5,U,3)["N":"NON-STATIC",1:"") 27 ..I $P(RR5,U,5) S Y=$P(RR5,U,5) D DD^%DT W !,?22,"Date of Exam: ",Y W:$P(RR5,U,6) " Examiner: ",$E($P(^VA(200,$P(RR5,U,6),0),U,1),1,30) 28 ..W !,?22,"Desc: " 29 ..W $S($D(R5(6,RA,1)):$P(R5(6,RA,1),U),1:""),! 30 ..I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 31 I '$D(R5(6)),$P(R5(0),U,6)="" W "NONE LISTED",! 32 S RO=0 33 F S RO=$O(^RMPR(667,"C",RMPRDFN,RO)) Q:RO'>0 D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 34 .Q:$P(^RMPR(667,RO,2),U,1)=0 35 .W:'$D(RMPRFLG) !,"Automobile(s):",?15,"Make",?27,"Model",?39,"Vehical ID #",?62,"Date Processed" 36 .W:'$P(^RMPR(667,RO,0),U,6)'="" !?15,$E($P(^RMPR(667.2,$P(^RMPR(667,RO,0),U,6),0),U,1),1,11),?27,$E($P(^RMPR(667,RO,0),U,7),1,10),?39,$P(^RMPR(667,RO,0),U,1) S Y=$P(^RMPR(667,RO,0),U,8) D DD^%DT W ?64,Y S RMPRFLG=1 37 I '$D(RMPRFLG) W !,"Automobile(s): NONE LISTED" 38 W !,"Items Returned: " 39 I $D(^RMPR(665,RMPRDFN,7,0)) D OLD^RMPRPAT1 40 I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO'>0 D WRIL^RMPRPAT1 41 I '$D(^RMPR(660.1,"C",RMPRDFN)) W "NONE LISTED" 42 ;W !!,"Items on loan: " I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO="" D WRIL^RMPRPAT1 43 W !!,"Other Data: " S J=0 F I=1:1 S J=$O(R5(4,J)) Q:J=""!(J?.A) W !?5,R5(4,J,0) I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 44 I I=1 W "NONE LISTED" 45 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 46 W !,"RECORD OF APPLIANCES/REPAIRS: " D HDRH S RC=0,(RA,AN)="" 47 S RA="" 48 F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA'>0 S AN="" F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN'>0 S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 49 S RA="" 50 I RMPRMERG D 51 . F S RA=$O(^RMPR(660,"AC",RMPRMERG,RA)) Q:RA'>0 S AN="" F S AN=$O(^RMPR(660,"AC",RMPRMERG,RA,AN)) Q:AN'>0 S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 52 I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! 53 E W !!,"End of Appliance/Repair records for this veteran!",!!," *Historical Item" 54 EXIT K I,IT,J,L,RC,K,RA,AN,DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM,R0,RMPRE,RMPRFLG,RO,Y G EXIT^RMPRPRT 55 HDRH W !!?4,"DATE",?13,"QTY",?17," HCPCS DESC",?29,"N R ",?33,"VENDOR",?45,"STA",?50,"SERIAL NBR",?62,"DELIVERED",?72,"COST",! 56 F L=1:1:79 W "-" 57 Q 58 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7),VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11),DEL=$P(Y,U,12),AMIS=$P(Y,U,15) 59 ;include 2529-3 data 60 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 61 ;vendor 2529-3 62 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D 63 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q 64 .I RMPRLPRO="R" S RMPRLPRO="RESTROATION" Q 65 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q 66 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q 67 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q 68 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q 69 S FRM=$P(Y,U,13),REM=$P(Y,U,18),DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 70 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 71 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 72 S VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 73 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" 74 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 75 W !,RC,". ",DATE,?13,QTY,?17 76 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 77 ;AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 78 ;I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 79 W ?29,TRANS,?31,TRANS1 80 ;display source of procurement 2529-3 under vendor header 81 I $D(RMPRLPRO) W ?33,RMPRLPRO 82 K RMPRLPRO 83 I VEN'="" W ?33,$E(VEN,1,10) 84 W:$G(STA)'="" ?45,$P($G(^DIC(4,STA,99)),U,1) W ?50,$E(SN,1,10),?62,DEL,?72,$J($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),0,2) 85 W:REM]"" !,?5,"REMARKS: ",REM I $Y+6>IOSL D HDR^RMPRPRT,HDRH 86 S (DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM)="" 87 Q 1 RMPRPRT1 ;PHX/HNB-CONTINUATION OF PRINT 2319 ;10/19/1993 2 ;;3.0;PROSTHETICS;**10,99**;Feb 09, 1996 3 ;CALLED BY END^RMPRPRT 4 ;VARIABLES REQUIRED: R5 - A STRING ARRAY HOLDING PATIENT'S PROSTHETIC 5 ; DISABILITY CODE INFORMATION 6 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 7 W !!,"PSC Issue Card: " S J=0 W ! 8 F I=1:1 D Q:J'>0 9 .I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 10 .S J=$O(R5(5,J)) Q:J=""!(J?.A) Q:$G(J)<1 11 .S L=$P(R5(5,J,0),U,1) ;S L=$P(R5(5,J,0),U,1) 12 .W $E(L,4,5)_"-"_$E(L,6,7)_"-"_$E(L,2,3),?17,"Appl: ",$S($D(^RMPR(661,+$P(R5(5,J,0),U,4),0)):$E($P(^PRC(441,+$P(^(0),U),0),U,2),1,37),1:"UNKNOWN"),?66,"SN: ",$P(R5(5,J,0),U,3),! 13 I I=1 W "NONE LISTED",! 14 W !,"Clothing Allowance: ",! 15 I $D(R5(6)),$O(R5(6,0))>0 D 16 .F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,6,"B",RI)) Q:RI'>0 D 17 ..S RA=$O(^RMPR(665,RMPRDFN,6,"B",RI,0)) 18 ..S RR5=R5(6,RA,0),RR5=RR5 19 ..;D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 20 ..W ?22,"DATE: ",$E(RR5,4,5)_"-"_$E(RR5,6,7)_"-"_$E(RR5,2,3) 21 ..W " ",$S($P(RR5,U,2)["E":"ELIGIBLE",$P(RR5,U,2)["N":"NOT-ELIGIBLE",1:"") 22 ..W " ",$S($P(RR5,U,3)["S":"STATIC",$P(RR5,U,3)["N":"NON-STATIC",1:"") 23 ..I $P(RR5,U,5) S Y=$P(RR5,U,5) D DD^%DT W !,?22,"Date of Exam: ",Y W:$P(RR5,U,6) " Examiner: ",$E($P(^VA(200,$P(RR5,U,6),0),U,1),1,30) 24 ..W !,?22,"Desc: " 25 ..W $S($D(R5(6,RA,1)):$P(R5(6,RA,1),U),1:""),! 26 ..I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 27 I '$D(R5(6)),$P(R5(0),U,6)="" W "NONE LISTED",! 28 S RO=0 29 F S RO=$O(^RMPR(667,"C",RMPRDFN,RO)) Q:RO'>0 D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 30 .Q:$P(^RMPR(667,RO,2),U,1)=0 31 .W:'$D(RMPRFLG) !,"Automobile(s):",?15,"Make",?27,"Model",?39,"Vehical ID #",?62,"Date Processed" 32 .W:'$P(^RMPR(667,RO,0),U,6)'="" !?15,$E($P(^RMPR(667.2,$P(^RMPR(667,RO,0),U,6),0),U,1),1,11),?27,$E($P(^RMPR(667,RO,0),U,7),1,10),?39,$P(^RMPR(667,RO,0),U,1) S Y=$P(^RMPR(667,RO,0),U,8) D DD^%DT W ?64,Y S RMPRFLG=1 33 I '$D(RMPRFLG) W !,"Automobile(s): NONE LISTED" 34 W !,"Items Returned: " 35 I $D(^RMPR(665,RMPRDFN,7,0)) D OLD^RMPRPAT1 36 I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO'>0 D WRIL^RMPRPAT1 37 I '$D(^RMPR(660.1,"C",RMPRDFN)) W "NONE LISTED" 38 ;W !!,"Items on loan: " I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO="" D WRIL^RMPRPAT1 39 W !!,"Other Data: " S J=0 F I=1:1 S J=$O(R5(4,J)) Q:J=""!(J?.A) W !?5,R5(4,J,0) I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 40 I I=1 W "NONE LISTED" 41 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 42 W !,"RECORD OF APPLIANCES/REPAIRS: " D HDRH S RC=0,(RA,AN)="" 43 S RA="" 44 F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA'>0 S AN="" F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN'>0 S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 45 I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! 46 E W !!,"End of Appliance/Repair records for this veteran!",!!," *Historical Item" 47 EXIT K I,IT,J,L,RC,K,RA,AN,DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM,R0,RMPRE,RMPRFLG,RO,Y G EXIT^RMPRPRT 48 HDRH W !!?4,"DATE",?13,"QTY",?17," HCPCS DESC",?29,"N R ",?33,"VENDOR",?45,"STA",?50,"SERIAL NBR",?62,"DELIVERED",?72,"COST",! 49 F L=1:1:79 W "-" 50 Q 51 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7),VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11),DEL=$P(Y,U,12),AMIS=$P(Y,U,15) 52 ;include 2529-3 data 53 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 54 ;vendor 2529-3 55 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D 56 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q 57 .I RMPRLPRO="R" S RMPRLPRO="RESTROATION" Q 58 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q 59 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q 60 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q 61 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q 62 S FRM=$P(Y,U,13),REM=$P(Y,U,18),DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 63 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 64 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 65 S VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 66 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" 67 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 68 W !,RC,". ",DATE,?13,QTY,?17 69 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 70 ;AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 71 ;I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 72 W ?29,TRANS,?31,TRANS1 73 ;display source of procurement 2529-3 under vendor header 74 I $D(RMPRLPRO) W ?33,RMPRLPRO 75 K RMPRLPRO 76 I VEN'="" W ?33,$E(VEN,1,10) 77 W ?45,$P(^DIC(4,STA,99),U,1),?50,$E(SN,1,10),?62,DEL,?72,$J($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),0,2) 78 W:REM]"" !,?5,"REMARKS: ",REM I $Y+6>IOSL D HDR^RMPRPRT,HDRH 79 S (DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM)="" 80 Q
Note:
See TracChangeset
for help on using the changeset viewer.
