- 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/RMPRPAT2.m
r613 r623 1 RMPRPAT2 ;PHX/RFM/JLT/HNC-DISPLAY PATIENT ITEM ACTIVITY ;10/19/1993 2 ;;3.0;PROSTHETICS;**32,34,29,44,99,75,137**;Feb 09, 1996;Build 5 3 D HDR N RMPRMERG S RMPRMERG=0 4 S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT 5 MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN) 6 ;Check for merged accounts 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) Q:RMPRMERG=0 10 . MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRMERG) 11 S B=0 12 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D 13 . S BC=0 14 . F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D 15 . .Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA") 16 . .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1) 17 . .S ND=$P($G(^RMPR(660,BC,1)),U,4) 18 . .I ND S ND=$P(^RMPR(661.1,ND,0),U,8) 19 . .S:ND="" ND=2 20 . .S:GN="" GN=BC 21 . .S ^TMP($J,"AG",GN,ND,BC)=B 22 S B="" 23 F S B=$O(^TMP($J,"AG",B)) Q:+B=0 D 24 .S BC="" 25 .F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D 26 . .Q:BC=2 27 . .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B) 28 . .S HC="",GTCST=0 29 . .K HCC1 30 . .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D 31 . . .S HCC=0 32 . . .;changes for Surgical Implants 33 . . .S BDC="" 34 . . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D 35 . . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16) 36 . . . .I BDC=1&(HC'=2) S HCC1=HCC 37 . . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) 38 . . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) 39 . .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1 40 . .K GTCST,^TMP($J,"AGG") 41 K ^TMP($J,"AG"),BDC 42 S B=0,RC=1 43 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D 44 .S RK=0 45 .F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D 46 . .Q:$D(^RMPO(665.72,"AC",RK)) 47 . .S IT(RC)=RK 48 . .I $P(^TMP($J,"TT",B,RK),U,3) S $P(IT(RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3) 49 . .S RC=RC+1 50 S RK=0,RZ=0 51 K ^TMP($J,"TT"),B 52 ; 53 G:'$D(IT) END 54 DIS ;DISPLAY APPLIANCES OR REPAIRS 55 I $G(RK)="" S RK="",RC="" 56 I (RK+1'>RC)&($G(IT(RK+1))) S RK=RK+1 S AN=+IT(RK),Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y) G:'$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) EXIT G DIS 57 END I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! H 3 G EXIT 58 ; 59 I RC>0 W !!,"End of Appliance/Repair records for this veteran!" D OVER I $G(RK)+1'>$G(RC)&($G(IT($G(RK)+1))) D DIS 60 ; 61 EXIT K I,J,L,R0,IT,RA 62 Q:'$D(RMPRDFN) 63 W ! 64 I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT 65 S FL=4 G ASK2^RMPRPAT 66 Q 67 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7) 68 S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11) 69 S DEL=$P(Y,U,12) 70 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 71 ;lab source of procurement 72 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D 73 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q 74 .I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q 75 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q 76 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q 77 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q 78 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q 79 ;form requested on 80 S FRM=$P(Y,U,13),REM=$P(Y,U,18) 81 S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 82 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 83 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 84 S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 85 I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+" 86 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" 87 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 88 W !,RK,". ",DATE,?13,QTY,?17 89 ;W 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:"") 90 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:"") 91 ;historical item 92 I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 93 W ?30,TRANS,?31,TRANS1 94 ;display source of procurement for 2529-3 under vendor header 95 I $D(RMPRLPRO) W ?33,RMPRLPRO 96 ;I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10) 97 I VEN'="" W ?33,$E(VEN,1,10) 98 K RMPRLPRO 99 ;historical vendor 100 W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10) 101 W:STA'="" ?45,$P(^DIC(4,STA,99),U,1) 102 W ?50,$E(SN,1,9),?60,DEL 103 I $P(IT(RK),U,3) S CST=$P(IT(RK),U,3) 104 W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9) 105 W:REM]"" !,?3,REM 106 I $P(IT(RK),U,2)="" S $P(IT(RK),U,2)=RZ 107 Q 108 OVER ; 109 N ANS 110 S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^" 111 I ANS="^^" S ANS="^" G ASK1^RMPRPAT Q 112 I ANS="^" G ASK1^RMPRPAT Q 113 I ANS="",RK+1'>RC&($G(IT(RK+1))) D HDR Q 114 I ANS="" Q 115 I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER 116 I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3 117 S RK=$P(IT(ANS),U,2) 118 Q 119 HDR ;Print Header, Screen 4 120 W @IOF 121 S PAGE=3 122 W !,$E(RMPRNAM,1,20),?23,"SSN: " 123 W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10) 124 W ?42,"DOB: " 125 S Y=RMPRDOB X ^DD("DD") W Y K Y 126 W ?61,"CLAIM# ",$G(RMPRCNUM) 127 W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost" 128 Q 1 RMPRPAT2 ;PHX/RFM/JLT/HNC-DISPLAY PATIENT ITEM ACTIVITY ;10/19/1993 2 ;;3.0;PROSTHETICS;**32,34,29,44,99,75**;Feb 09, 1996;Build 25 3 D HDR 4 S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT 5 MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN) 6 S B=0 7 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D 8 . S BC=0 9 . F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D 10 . .Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA") 11 . .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1) 12 . .S ND=$P($G(^RMPR(660,BC,1)),U,4) 13 . .I ND S ND=$P(^RMPR(661.1,ND,0),U,8) 14 . .S:ND="" ND=2 15 . .S:GN="" GN=BC 16 . .S ^TMP($J,"AG",GN,ND,BC)=B 17 S B="" 18 F S B=$O(^TMP($J,"AG",B)) Q:B'>0 D 19 .S BC="" 20 .F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D 21 . .Q:BC=2 22 . .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B) 23 . .S HC="",GTCST=0 24 . .K HCC1 25 . .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D 26 . . .S HCC=0 27 . . .;changes for Surgical Implants 28 . . .S BDC="" 29 . . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D 30 . . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16) 31 . . . .I BDC=1&(HC'=2) S HCC1=HCC 32 . . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) 33 . . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) 34 . .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1 35 . .K GTCST,^TMP($J,"AGG") 36 K ^TMP($J,"AG"),BDC 37 S B=0,RC=1 38 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D 39 .S RK=0 40 .F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D 41 . .Q:$D(^RMPO(665.72,"AC",RK)) 42 . .S IT(RC)=RK 43 . .I $P(^TMP($J,"TT",B,RK),U,3) S $P(IT(RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3) 44 . .S RC=RC+1 45 S RK=0,RZ=0 46 K ^TMP($J,"TT"),B 47 ; 48 G:'$D(IT) END 49 DIS ;DISPLAY APPLIANCES OR REPAIRS 50 I $G(RK)="" S RK="",RC="" 51 I (RK+1'>RC)&($G(IT(RK+1))) S RK=RK+1 S AN=+IT(RK),Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y) G:'$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) EXIT G DIS 52 END I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! H 3 G EXIT 53 ; 54 I RC>0 W !!,"End of Appliance/Repair records for this veteran!" D OVER I $G(RK)+1'>$G(RC)&($G(IT($G(RK)+1))) D DIS 55 ; 56 EXIT K I,J,L,R0,IT,RA 57 Q:'$D(RMPRDFN) 58 W ! 59 I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT 60 S FL=4 G ASK2^RMPRPAT 61 Q 62 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7) 63 S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11) 64 S DEL=$P(Y,U,12) 65 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 66 ;lab source of procurement 67 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D 68 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q 69 .I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q 70 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q 71 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q 72 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q 73 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q 74 ;form requested on 75 S FRM=$P(Y,U,13),REM=$P(Y,U,18) 76 S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 77 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 78 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 79 S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 80 I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+" 81 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" 82 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 83 W !,RK,". ",DATE,?13,QTY,?17 84 ;W 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:"") 85 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:"") 86 ;historical item 87 I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 88 W ?30,TRANS,?31,TRANS1 89 ;display source of procurement for 2529-3 under vendor header 90 I $D(RMPRLPRO) W ?33,RMPRLPRO 91 ;I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10) 92 I VEN'="" W ?33,$E(VEN,1,10) 93 K RMPRLPRO 94 ;historical vendor 95 W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10) 96 W:STA'="" ?45,$P(^DIC(4,STA,99),U,1) 97 W ?50,$E(SN,1,9),?60,DEL 98 I $P(IT(RK),U,3) S CST=$P(IT(RK),U,3) 99 W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9) 100 W:REM]"" !,?3,REM 101 I $P(IT(RK),U,2)="" S $P(IT(RK),U,2)=RZ 102 Q 103 OVER ; 104 N ANS 105 S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^" 106 I ANS="^^" S ANS="^" G ASK1^RMPRPAT Q 107 I ANS="^" G ASK1^RMPRPAT Q 108 I ANS="",RK+1'>RC&($G(IT(RK+1))) D HDR Q 109 I ANS="" Q 110 I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER 111 I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3 112 S RK=$P(IT(ANS),U,2) 113 Q 114 HDR ;Print Header, Screen 4 115 W @IOF 116 S PAGE=3 117 W !,$E(RMPRNAM,1,20),?23,"SSN: " 118 W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10) 119 W ?42,"DOB: " 120 S Y=RMPRDOB X ^DD("DD") W Y K Y 121 W ?61,"CLAIM# ",$G(RMPRCNUM) 122 W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost" 123 Q
Note:
See TracChangeset
for help on using the changeset viewer.
