source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR5N3.m@ 1250

Last change on this file since 1250 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1RMPR5N3 ;HIN/RVD-PRINT INVENTORY BALANCE BY HCPCS ;3/17/03 13:19
2 ;;3.0;PROSTHETICS;**33,37,77**;Feb 09, 1996
3 ;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION.
4 D DIV4^RMPRSIT I $D(Y),(Y<0) Q
5 S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
6 ;
7EN K ^TMP($J),RMPRI,RMPRFLG S RMPREND=0 D HOME^%ZIS S DIC="^RMPR(661.1,",DIC(0)="AEQM",DIC("S")="I $D(^RMPR(661.1,+Y,0)),($P(^(0),U,9)=1)"
8EN1 R !!,"Enter 'ALL' for all HCPCS or 'RETURN' to select individual HCPCS: ",RMENTER:DTIME G:$D(DTOUT)!$D(DUOUT)!(RMENTER="^") EXIT1
9 G:RMENTER["?" EN1
10 S X=RMENTER X ^%ZOSF("UPPERCASE") S RMENTER=Y I RMENTER="ALL" S RMPRI(0)=1 G CONT
11SEL W ! F RML=1:1 S DIC("A")="Select HCPCS "_RML_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(RML=1)) EXIT1 Q:X="" D
12 .S RMI=$P(^RMPR(661.1,+Y,0),U,1)
13 .I $D(RMPRI(RMI)) W $C(7)," ??",?40,"..Duplicate HCPCS" S RML=RML-1 Q
14 .S RMPRI(RMI)=+Y
15CONT G:'$D(RMPRI) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1 I '$D(IO("Q")) U IO G PRINT
16 K IO("Q") S ZTDESC="PROSTHETIC INVENTORY LOCATION SUMMARY",ZTRTN="PRINT^RMPR5N3",ZTIO=ION,ZTSAVE("RMPRI(")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMDAT")="",ZTSAVE("RMPR(")=""
17 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
18 ;
19PRINT I $E(IOST)["C" W !!,"Processing report......."
20 S RMPAGE=1,(RMTOBAL,RMPREND)=0,RS=RMPR("STA") M ^TMP($J,"RM")=RMPRI
21 D:$D(RMPRI(0)) ALL
22 I '$D(^TMP($J,"RM")) D NONE G EXIT
23 S RB="" F S RB=$O(^TMP($J,"RM",RB)) Q:RB="" S RMLIEN=^TMP($J,"RM",RB) D
24 .S J=0 F S J=$O(^RMPR(661.3,"C",RMLIEN,J)) Q:J'>0 S R63=$G(^RMPR(661.3,J,0)) I R63'="" S RMLO=$P(R63,U,1) S R3=$O(^RMPR(661.3,"C",RMLIEN,J,0)) I R3 D
25 ..F R4=0:0 S R4=$O(^RMPR(661.3,J,1,R3,1,R4)) Q:R4'>0 Q:$P(R63,U,3)'=RS D
26 ...S RM3=$G(^RMPR(661.3,J,1,R3,1,R4,0)) Q:RM3=""
27 ...S RMIT=$P(RM3,U,1),RMHCPC=$P(RMIT,"-",1),RMDAIT=$P(RMIT,"-",2)
28 ...S RMITEM=$P($G(^RMPR(661.1,RMLIEN,3,RMDAIT,0)),U,1) Q:RMITEM=""
29 ...S RMUNI=$P(RM3,U,4),RMRLE=$P(RM3,U,6),RMDI=$P(RM3,U,7),RMSO=$P(RM3,U,9),RMAV=$P(RM3,U,10)
30 ...S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMVE=$P(RM3,U,5)
31 ...S ^TMP($J,RB,RMITEM,RMLO)=RMAV_"^"_RMVE_"^^"_RMUNI_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMBA_"^"_RMCO
32 W:$E(IOST)["C" @IOF
33 D HEAD,WRI D:RMSUF TOTAL G EXIT
34 ;write/print report
35WRI S RP="",RMSUF=0 D HEAD1
36 F S RP=$O(^TMP($J,RP)) Q:(RP="")!(RMPREND) D:RMSUF TOTAL K RMPRFLG F S J=$O(^TMP($J,RP,J)) Q:(J="")!(RMPREND) S K="",RSA=RP F S K=$O(^TMP($J,RP,J,K)) Q:(K="")!(RMPREND) D
37 .S RMAST="",RMTMP=^TMP($J,RP,J,K),RMVE=$P(RMTMP,U,2)
38 .S RMUNI=$P(RMTMP,U,4),RMRLE=$P(RMTMP,U,5),RMDI=$P(RMTMP,U,6),RMSO=$P(RMTMP,U,7),RMBA=$P(RMTMP,U,8),RMCO=$P(RMTMP,U,9),RMAV=$P(RMTMP,U,1)
39 .S RMITEM=J,RMLOC=K,RMSUF=1,RMTOBAL=RMTOBAL+RMBA
40 .S:RMUNI RMUNI=$P(^PRCD(420.5,RMUNI,0),U,1)
41 .S:RMVE RMVE=$P($G(^PRC(440,RMVE,0)),U,1)
42 .S RMITEM=$E(RMITEM,1,20)
43 .S:RMBA<RMRLE RMAST="*"
44 .W !,RP,?9,RMITEM,?30,RMSO,?33,$E(RMLOC,1,8),?42,$E(RMVE,1,11),?55,RMUNI,?58,$J(RMRLE,4),?64,$J(RMAV,8,2),?73,$J(RMBA,5),RMAST
45 .S RMPRFLG=1
46 .I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD,HEAD1 Q
47 .I $Y>(IOSL-6) W @IOF D HEAD,HEAD1 K RMPRFLG Q
48 Q
49 ;
50TOTAL W !,?71,"-------",!,?45,"Total ",RSA," balance = ",?71,$J(RMTOBAL,7),!,RMPR("L")
51 S RMSUF=0,RMTOBAL=0
52 Q
53 ;
54HEAD W !,"*** PROSTHETICS INVENTORY BALANCE BY HCPCS ***",?68,"PAGE: ",RMPAGE,!,"Run Date: ",RMDAT,?30,"station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,20)
55 S RMPAGE=RMPAGE+1
56 Q
57 ;
58HEAD1 I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD
59 I $E(IOST)'["C"&($Y>(IOSL-6)) W @IOF D HEAD
60 W !,RMPR("L")
61 W !,?54,"UNIT",?60,"RE-"
62 W !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
63 W !,"HCPCS",?9,"ITEM",?29,"SRC",?33,"LOCATION",?42,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
64 W !,"-----",?9,"----",?29,"---",?33,"--------",?42,"------",?53,"-----",?59,"-----",?68,"----",?75,"---"
65 S RMPRFLG=1
66 Q
67 ;
68ALL ;process all items
69 K RMPRI(0),^TMP($J,"RM")
70 F I=0:0 S I=$O(^RMPR(661.1,I)) Q:I'>0 I $P(^RMPR(661.1,I,0),U,9)=1 S RMI=$P(^RMPR(661.1,I,0),U,1) S:RMI'="" ^TMP($J,"RM",RMI)=I
71 Q
72 ;
73EXIT I $E(IOST)["C",'RMPREND W ! S DIR(0)="E" D ^DIR
74EXIT1 D ^%ZISC
75 N RMPR,RMPRSITE D KILL^XUSCLEAN
76 Q
77NONE W !!,"NO DATA !!!!!"
78 Q
Note: See TracBrowser for help on using the repository browser.