- 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/RMPR4LOP.m
r613 r623 1 RMPR4LOP 2 ;;3.0;PROSTHETICS;**3,20,140**;Feb 09, 1996;Build 10 3 4 5 6 7 8 9 START 10 11 12 13 14 15 16 PRINT 17 18 19 20 21 22 23 EXIT 24 25 EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J),PRCIEND ^%ZISC26 27 28 CK 29 30 31 32 33 34 35 36 37 WRI 38 39 40 41 42 43 S RD=$P(^RMPR(664,RP,0),U,1),PRCIEN=$P(^RMPR(664,RP,4),U,6)44 45 W ?36,RD I PRCIEN,($P($G(^PRC(442,PRCIEN,7)),U)=45) W "#" 46 47 48 49 50 51 52 ITE 53 54 55 56 57 58 59 COST 60 61 62 63 64 65 66 67 68 69 HDR 70 71 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",! S PAGE=PAGE+1 Q1 RMPR4LOP ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,20**;Feb 09, 1996 3 ;sort by originator, assistance from Long Beach PVB 4 W !,"This report lists Open Purchase Card Transactions created in the" 5 W !,"Prosthetics Package." 6 W !!,"This report is sorted by Transaction Date and Initiator.",! 7 W !,"The PC # column is the abbreviated Purchase Card Transaction Number," 8 W !,"Example: 644-PC546, would display as 546.",!! 9 START K ^TMP($J) D DIV4^RMPRSIT G:$D(X) EX S RMPRCOUN=0 D HOME^%ZIS W !! S %DT("A")="Starting Date: ",%DT="AEPX" D ^%DT S RMPRBDT=Y G:Y<0 EX 10 S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EX I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G START 11 S RMPREDT=Y,Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y 12 S %ZIS="MQ" K IOP D ^%ZIS G:POP EX 13 I '$D(IO("Q")) U IO G PRINT 14 S ZTDESC="OPEN 2421PC TRANSACTIONS",ZTRTN="PRINT^RMPR4LOP",ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(")="" 15 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EX 16 PRINT S X1=RMPRBDT,X2=-1 D C^%DTC S RO=X,RP=0,PAGE=1,RMPRCOUN=0,INIC="",RMPREND="" I IOST["C-" D WAIT^DICD 17 F S RO=$O(^RMPR(664,"B",RO)) Q:RO'>0 Q:RO>RMPREDT F S RP=$O(^RMPR(664,"B",RO,RP)) Q:RP'>0 D CK 18 S (RP,RMPROBL,CNT)="" 19 F S RMPROBL=$O(^TMP($J,RMPROBL)) Q:RMPROBL'>0 Q:RMPREND=1 D I RMPREND'=1 W !,?71,"=========",!,?65,"Total ",$J($FN(CNT,"P",2),9) S CNT=0 H 1 20 .F S RP=$O(^TMP($J,RMPROBL,RP)) Q:RP'>0 Q:RMPREND=1 S INIB=$P(^VA(200,$P(^RMPR(664,RP,0),U,9),0),U,1) D WRI 21 I $D(RMPREDT)&(RMPRCOUN=0) W @IOF D HDR W $C(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!" 22 ; 23 EXIT I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20 24 I $D(RMPREDT),'$D(DTOUT),'$D(DUOUT),$E(IOST)["C",'$D(RMPRFLL),RMPREND'=1 S DIR(0)="E" D ^DIR 25 EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J) D ^%ZISC 26 K CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS,INIC,INIB 27 Q 28 CK ;check record, apply screen 29 Q:'$D(^RMPR(664,RP,0)) 30 ;vendor, purchase card, cancelation date, close-out date 31 Q:$P(^RMPR(664,RP,0),U,4)=""!($P($G(^(4)),U,1)="")!($P(^(0),U,5)'="")!($P(^(0),U,8)'="") 32 Q:$P(^RMPR(664,RP,0),U,14)'=""&($P(^(0),U,14)'=RMPR("STA")) 33 S RMPROBL=$P(^RMPR(664,RP,0),U,9) 34 Q:'RMPROBL 35 S ^TMP($J,RMPROBL,RP)="",RMPRCOUN=RMPRCOUN+1 36 Q 37 WRI I '$D(RMPRFLG)!(INIC'=INIB) D HDR W !,"Initiator: ",INIB,!,"Patient",?14,"SSN",?19,"Purchase Card",?36,"Date",?43,"PC #",?50,"Vendor",?62,"Item",?70,"Item Cost",!,RMPR("L") 38 W !,$E($P(^DPT($P(^RMPR(664,RP,0),U,2),0),U,1),1,12) 39 W ?14,$E($P(^DPT($P(^RMPR(664,RP,0),U,2),0),U,9),6,9) 40 W ?19 41 I DUZ=$P(^RMPR(664,RP,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) W $$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP) 42 E W "encrypted" 43 S RD=$P(^RMPR(664,RP,0),U,1) 44 S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7) 45 W ?36,RD 46 W ?43,$P(^RMPR(664,RP,4),U,5) 47 W ?50 48 W:+$P(^RMPR(664,RP,0),U,4) $E($P(^PRC(440,$P(^RMPR(664,RP,0),U,4),0),U,1),1,10) 49 D ITE 50 S INIC=INIB 51 Q 52 ITE I '$D(^RMPR(664,RP,1))&($P(^RMPR(664,RP,0),U,12)) W ?61,"*DELIVERY",?71,$J($FN($P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,16),"P",2),9) S RMPRFLG=1 53 I S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,16) D:$Y>(IOSL-6) HDR Q 54 I $P(^RMPR(664,RP,0),U,12)'="" W ?61,"*SHIPPING",?71,$J($FN($P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,17),"P",2),9),! 55 I S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,17) 56 S (IT)=0 57 F S IT=$O(^RMPR(664,RP,1,IT)) Q:IT'>0!($D(DUOUT))!($D(DTOUT)) W:IT>1 ! W ?61,$E($P(^PRC(441,$P(^RMPR(661,$P(^RMPR(664,RP,1,IT,0),U,1),0),U,1),0),U,2),1,10) Q:$P(^RMPR(664,RP,1,IT,0),U,13)="" D COST 58 Q 59 COST W ?71 60 W $J($FN($P(^RMPR(660,$P(^RMPR(664,RP,1,IT,0),U,13),0),U,16),"P",2),9) 61 S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,1,IT,0),U,13),0),U,16) 62 S RMPRFLG=1 63 I $E(IOST)["C"&($Y>(IOSL-6)) W ! S DIR(0)="E" D ^DIR S:Y<1 RMPREND=1 Q:Y="" S:Y<1 RMPRFLL=1 Q:Y<1 S:$D(DTOUT) RMPREND=1 Q:$D(DTOUT) D HDR Q 64 I $Y>(IOSL-6) K RMPRFLG 65 Q 66 ;header 67 I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20 68 I INIC'=""!(PAGE'=1)&(INIC'=INIB)&($E(IOST)["C") S DIR(0)="E" D ^DIR 69 HDR I PAGE'=1!($E(IOST)["C") W @IOF 70 I $E(IOST)["C" W @IOF G EXIT:X="^" 71 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! S PAGE=PAGE+1 Q
Note:
See TracChangeset
for help on using the changeset viewer.
