Changeset 636 for FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (15 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 28 edited
- 1 copied
-
. (copied) (copied from FOIAVistA/trunk/r )
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPOBIL5.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m (modified) (3 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m (modified) (3 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR29A.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR29BG.m (modified) (3 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR29CA.m (modified) (7 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR4C21.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR4E21.m (modified) (4 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR4LOP.m (modified) (4 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR4OPN.m (modified) (4 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P21.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR8PG.m (modified) (3 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR9CA.m (modified) (3 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR9DO.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPR9P21.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRD1.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRDDC.m (modified) (4 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPREOS.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPREOU.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRP21.m (modified) (5 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRPAT2.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCEB.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCED.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYF.m (modified) (2 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRPRT1.m (modified) (3 diffs)
-
PROSTHETICS-RMPR-RMPO-RMPS/RMPRSP7.m (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOBIL5.m
r628 r636 1 1 RMPOBIL5 ;(NG)/DUG - HOME OXYGEN BILLING TRANSACTIONS ;7/24/98 2 ;;3.0;PROSTHETICS;**29,99,137**;Feb 09, 1996;Build 5 3 N RMPRMERG S RMPRMERG=0 2 ;;3.0;PROSTHETICS;**29,99**;Feb 09, 1996 4 3 S (RC,RA,AN,ANS,RK,RZ)=0 D HDR 5 4 F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA="" D … … 7 6 . F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN="" D 8 7 . . I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN 9 ;Check for merged accounts10 I $D(^XDRM("B",RMPRDFN_";DPT(")) D11 . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""12 . S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=0 D13 .. S RA=014 .. F S RA=$O(^RMPR(660,"AC",RMPRMERG,RA)) Q:RA="" D15 ... S AN=""16 ... F S AN=$O(^RMPR(660,"AC",RMPRMERG,RA,AN)) Q:AN="" D17 .... I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN18 8 G:'$D(IT) END 19 9 DIS ;DISPLAY APPLIANCES OR REPAIRS -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m
r628 r636 1 1 RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98 2 ;;3.0;PROSTHETICS;**29,44,41,52,77,110 ,140**;Feb 09, 1996;Build 102 ;;3.0;PROSTHETICS;**29,44,41,52,77,110**;Feb 09, 1996;Build 10 3 3 ; 4 4 ; HNC - patch 52 … … 11 11 UNLOCK I $D(RMPODFN) L -^RMPR(665,RMPODFN) 12 12 Q 13 EXIT D KILL^XUSCLEAN13 EXIT K DIC,DIE,DIR,DIK,X,Y,Z,DR,DA,DD,DO,D0,DTOUT,DIROUT,DUOUT,DIRUT,QUIT,DFN,ITEM,ITEMS,IEN,IENS,ITMACT,ITM,C,S,W,PI,VDR,ZST 14 14 D UNLOCK 15 15 Q … … 171 171 RX ;Edit the Rx Data 172 172 ; 173 N RXD,RXDI174 173 K DIC,DIE,DA,DR 175 174 S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ" 176 175 S DA(1)=RMPODFN,DIC("P")="665.193D" 177 S RXD=$O(^RMPR(665,DA(1),"RMPOB","B",""),-1) D:RXD178 . S DIC("B")=$ $FMTE^XLFDT(RXD)176 I $D(^DISV(DUZ,DIC)) S Y=^(DIC) I $D(@(DIC_(+Y)_",0)")) D 177 . S DIC("B")=$P(^(0),U,1) 179 178 D ^DIC Q:Y<0!$$QUIT 180 179 S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m
r628 r636 1 1 RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003 2 ;;3.0;PROSTHETICS;**90,75 ,137**;FEB 09,1996;Build52 ;;3.0;PROSTHETICS;**90,75**;FEB 09,1996;Build 25 3 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2 … … 20 20 S PRCRMPR=1,X=1,PRCRMPR=1 21 21 D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) 22 I X="^" D C664G QUIT22 I X="^" G QUIT 23 23 S PRC442=$P(^RMPR(664,RMPRA,4),U,6) 24 24 I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT 25 S $P(^RMPR(664,RMPRA,0),U,5)="",$P(^RMPR(664,RMPRA,2),U)="",$P(^RMPR(664,RMPRA,2),U,2)=""26 25 I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC 27 26 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK … … 83 82 D DELIV^RMPR121A 84 83 Q 85 C664 ;CANCEL 664 ENTRY WHEN IFCAP IS CANCELLED86 S $P(^RMPR(664,RMPRA,0),U,5)=$P(^RMPR(664,RMPRA,0),U),$P(^RMPR(664,RMPRA,2),U,2)=+DUZ87 S WDS="INSUFF FUNDS CANCEL",DA=RMPRA,DR="3.1////^S X=WDS",DIE="^RMPR(664," D ^DIE K WDS88 Q -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29A.m
r628 r636 1 1 RMPR29A ;PHX/JLT,RVD-RMPR29 CONTINUED [ 09/29/94 11:22 AM ] 2 ;;3.0;PROSTHETICS;**12,13,28,41 ,142**;Feb 09, 1996;Build 22 ;;3.0;PROSTHETICS;**12,13,28,41**;Feb 09, 1996 3 3 POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660 4 4 I '$D(RMPRDA)!('$D(^RMPR(664.1,RMPRDA,2,0))) Q … … 11 11 F RA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0 I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),TYP=$P(^(0),U,7),ELS=$P(^(0),U,8),SCAT=$P(^(0),U,9),SER=$P(^(0),U,12) D 12 12 .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2) 13 .I RDA,'$D(^RMPR(660,RDA,0)) S RDA=""14 13 .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=RMPRDT D FILE^DICN K DLAYGO Q:+Y'>0 S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=RMPRDT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=RMPRDT 15 14 DR .K DR S DR="2///^S X=TYP;4.5////^S X=$G(HCPCS);5///^S X=QTY;9///^S X=SER;78///^S X=UN;8////^S X=RMPR(""STA"");11///^S X=4;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);4.7////^S X=RMCPT" -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29BG.m
r628 r636 1 1 RMPR29BG ;OI-HINES/SPS -OWL BASE HCPCS ENTER/EDIT/DELETE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**75 ,142**;Feb 09, 1996;Build 22 ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25 3 3 A1(RMAED,RMPRSITE,RMIE1,RMIE16,RMITM,RMQTY,RMUI,RMTT,RMPC,RMSN,RMHCPC,RMCPTM,RMVEN) ;roll and scroll entry point 4 4 G A2 5 5 EN(RESULTS,RMAED,RMPRSITE,RMIE1,RMIE16,RMITM,RMQTY,RMUI,RMTT,RMPC,RMSN,RMHCPC,RMCPTM,RMVEN,RMBD,RMHTECH,RMPRTXT) ;RPC entry point 6 6 A2 ; 7 N J,L,RESULTS,RMIE16C,RMIE16F ,R6641,RSITE7 N J,L,RESULTS,RMIE16C,RMIE16F 8 8 S RESULTS(0)="" 9 9 K ^TMP($J) … … 16 16 S ^TMP("SPS",0)=RMAED_U_RMPRSITE_U_RMIE1_U_RMIE16_U_RMITM_U_RMQTY_U_RMUI_U_RMTT_U_RMPC_U_RMSN_U_RMHCPC_U_RMCPTM_U_RMVEN 17 17 S RMIE16F=$O(^RMPR(664.1,RMIE1,2,0)) 18 S R6641=$G(^RMPR(664.1,RMIE1,0))19 S RSITE=$P(R6641,U,15),RSITE=$O(^RMPR(669.9,"C",RSITE,0))20 I RSITE'=RMPRSITE S RMPRSITE=RSITE21 18 I RMIE16F>0 S:RMIE16'=RMIE16F RMTT=$P(^RMPR(664.1,RMIE1,2,RMIE16F,0),U,7),RMPC=$P(^(0),U,8) 22 19 I RMIE16=RMIE16F D:RMTT'=$P(^RMPR(664.1,RMIE1,2,RMIE16F,0),U,7)!(RMPC'=$P(^(0),U,8)) … … 60 57 DEL ; 61 58 S DA=$P(^RMPR(664.1,RMIE1,2,RMIE16,0),U,5) 62 I DA'="" D 63 . S DIK="^RMPR(660," D ^DIK 64 . K DA,DIK 59 S DIK="^RMPR(660," D ^DIK 60 K DA,DIK 65 61 S DA=$P(^RMPR(664.1,RMIE1,2,RMIE16,0),U,6) 66 I DA'="" D 67 . S DIK="^RMPR(664.2," D ^DIK 68 . K DA,DIK 62 S DIK="^RMPR(664.2," D ^DIK 63 K DA,DIK 69 64 S DA(1)=RMIE1,DA=RMIE16,DIK="^RMPR(664.1,"_DA(1)_",2," D ^DIK 70 65 K DA,DIK -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29CA.m
r628 r636 1 1 RMPR29CA ;OI-HINES/HNC,SPS -WORK ORDER SUSPENSE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**75,122 ,142**;Feb 09, 1996;Build 22 ;;3.0;PROSTHETICS;**75,122**;Feb 09, 1996;Build 2 3 3 A1(RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;roll and scroll entry point 4 4 G A2 5 5 EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;RPC entry point 6 6 A2 ; 7 S RESULTS(0)="" ,STP=07 S RESULTS(0)="" 8 8 K ^TMP($J) 9 9 ; … … 11 11 ;3=cancel or 4=cancel and clone 12 12 S RMIE=0 13 F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D Q:STP=114 .S RMIE60=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5) Q:'RMIE6013 F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D 14 .S RMIE60=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5) 15 15 .S ^TMP($J,RMIE60)="" 16 .D FD 17 .I STP=1 Q 18 .D UPD 19 I STP=1 G EXIT 16 .D FD,UPD 20 17 I RMSUSTAT=1 D CNOTE 21 18 I RMSUSTAT=0 D INOTE,FD … … 24 21 I RMSUSTAT=4 D CANOTE^RMPR29CB 25 22 ;set status 26 G EXIT23 Q 27 24 CNOTE ;(#12) COMPLETION NOTE 28 25 ;set file 668 … … 101 98 D ^DIC 102 99 I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q 100 ;S DIE=DIC K DIC 103 101 S (DA,RMPRDA2)=+Y 102 ;S DR="1" D ^DIE 104 103 K DIE,DR,Y 104 ;S ^RMPR(668,RMIE68,1,0)="^668.011DA^1^1" 105 105 N RMPRC 106 106 S L="",LN=0 … … 167 167 S:RMSUSTAT="" RMSUSTAT=0 168 168 L +^RMPR(660,RMIE60):2 169 I $T=0 S RESULTS(0)="1^Someone else is Editing this entry! If this problem persists contact your IRM to clear the Lock Table",STP=1 Q169 I $T=0 S RESULTS(0)="1^Someone else is Editing this entry!" G EXIT 170 170 S RM680=$G(^RMPR(668,RMIE68,0)) 171 171 S RM688=$G(^RMPR(668,RMIE68,8)) … … 202 202 D FILE^DIE("","RMDAT","RMERROR") 203 203 L -^RMPR(660,RMIE60) 204 I $D(RMERROR) S RMERR=1 ,STP=1 GERR204 I $D(RMERROR) S RMERR=1 D ERR 205 205 ; 206 206 Q 207 207 UPD ;update file 668 with 2319 records 208 K DD,D O208 K DD,D0 209 209 S DA(1)=RMIE68 210 210 S DIC="^RMPR(668,"_DA(1)_","_"10," 211 211 S DIC(0)="L",DLAYGO=668,X=RMIE60 212 212 D FILE^DICN 213 K X,DD,DO214 213 S DA(1)=RMIE68 215 214 S DIC="^RMPR(668,"_DA(1)_","_"11," 216 215 S X=RMAMIS 217 216 D FILE^DICN 218 K DIC,X,DLAYGO,D O217 K DIC,X,DLAYGO,D0 219 218 Q 220 219 A3 G A4 … … 226 225 Q 227 226 ERR ;exit on error 228 S RESULTS(0)="1^ERROR WAS "_RMERROR("DIERR",1,"TEXT",1)229 227 EXIT ; 230 K %,BDC,RM688,RMAA,RMAMIS,RMCODT,RMDAT,RMDWRT,RMICD9,RMIE,RMIE60,RMINDT231 K RM PRCO,RMPRDI,RMSERV,RMSTAT,RMTRES,RMTYRE,STP232 Q228 K RMTYRE,RMTRES,RMSUSTAT,RMSTAT,RMSERV,RMEQU,RMPRTST,RMPRDUZ,RMPRDI,RMPRCO,RMPR6641,RMIE68 229 K RMIE60,RMIE,RMICD9,RMDWRT,RMDAT,RMCODT,RMAMIS,RMAA,RM688,RMPRTXT 230 K BDC,BAD,%,RMINDT,RMPREQU -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m
r628 r636 1 1 RMPR29GA ;PHX/JLT,RVD,SPS-RMPR29 CONTINUED [ 09/29/94 11:22 AM ] 2 ;;3.0;PROSTHETICS;**75,60 ,142**;Feb 09, 1996;Build 22 ;;3.0;PROSTHETICS;**75,60**;Feb 09, 1996;Build 18 3 3 ; Developed form RMPR29A for the GUI application 4 4 POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660 … … 14 14 .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2),RMHTECH=$P($G(^(2)),U,3) 15 15 .;Changed .01 and 1 fields to create date DT below 5/25/06 for 75 SPS 16 .I RDA,'$D(^RMPR(660,RDA,0)) S RDA=""17 16 .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=DT D FILE^DICN K DLAYGO Q:+Y'>0 S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=DT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=DT 18 17 DR .K DR -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4C21.m
r628 r636 1 1 RMPR4C21 ;PHX/HNB-CANCEL A PURCHASE CARD TRANSACTION;3/1/1996 2 ;;3.0;PROSTHETICS;**3,20,62 ,140**;Feb 09, 1996;Build 103 ;Per VHA Directive 2004-038, this routine should not be modified.2 ;;3.0;PROSTHETICS;**3,20,62**;Feb 09, 1996 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ;RVD patch #62 - pce interface 5 5 ; … … 25 25 S RMPR442=$P($G(^RMPR(664,RMPRA,4)),U,6) 26 26 I RMPR442="" G BYPASS 27 I $P($G(^PRC(442,RMPR442,7)),U)=45 W !!,"Purchase Card CANCELLED in IFCAP, will cancel open Pros PC order, hit return" R X:10 G BYPASS28 27 D CAN^PRCH7B(.X,RMPRA,RMPR442,0) 29 28 I X="^" W !!,"NOT CANCELED You must say YES to 'Approve and print Amendment number'" G EXIT -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4E21.m
r628 r636 1 1 RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133 ,137**;Feb 09, 1996;Build 52 ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133**;Feb 09, 1996;Build 2 3 3 ;TH Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23 4 4 ;RVD patch #62 - PCE processing and link to suspense … … 25 25 S RM(RMPRA,0)=$G(^RMPR(664,RMPRA,0)),RM(RMPRA,2)=$G(^(2)),RM(RMPRA,4)=$G(^(4)) 26 26 S RMPER=$P(RM(RMPRA,2),U,6),RMBAN=$P(RM(RMPRA,4),U,2),RMSHI=$P(RM(RMPRA,0),U,11),RMSHIEN=$P(RM(RMPRA,0),U,12) 27 S:RMSHI=""!(RMSHI+0=0) RMSHI=028 27 ;added by #62 29 28 ;collect all items and previous linkage to suspense. … … 78 77 I $P(^RMPR(664,RMPRA,0),U,11)="",$P(^(0),U,10) S $P(^(0),U,11)=$P(RM(RMPRA,0),U,10) 79 78 S DA=RMPRA,DIE="^RMPR(664,",DR="12;17;26" D ^DIE 80 S:+$P(^RMPR(664,RMPRA,0),U,11)=0 $P(^(0),U,11)=081 79 I RMPER'=$P(^RMPR(664,RMPRA,2),U,6) S RMPERF=1 82 80 I RMBAN'=$P(^RMPR(664,RMPRA,4),U,2) S RMBANF=1 83 I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11)!($P(^(0),U,11)=0&$P(^(0),U,12)) S RMSHIF=1 81 I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11) S RMSHIF=1 82 S:$P(^RMPR(664,RMPRA,0),U,11)="" $P(^(0),U,11)=0 84 83 CHK1 ;delete imcomplete items 85 84 S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)) Q:I'>0 S RMPRI=$G(^(I,0)) I $P(RMPRI,U,3)=""!($P(RMPRI,U,4)="")!($P(RMPRI,U,5)="") S DA=I D ^DIK … … 140 139 .I DA'="" S SKPSHDT=1 D ^RMPR4E23 K SKPSHDT 141 140 EX1 ; 142 I $D(RM60LINK) D143 . F I=0:0 S I=$O(RM60LINK(I)) Q:I'>0 D144 .. I '$D(^RMPR(660,I,0)) K RM60LINK(I)145 141 ;added by #62 146 142 D:$D(RM68FG)=1 AUTO^RMPRPCEL D:$D(RM68FG)>1 MAN^RMPRPCEL -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4LOP.m
r628 r636 1 1 RMPR4LOP ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,20 ,140**;Feb 09, 1996;Build 102 ;;3.0;PROSTHETICS;**3,20**;Feb 09, 1996 3 3 ;sort by originator, assistance from Long Beach PVB 4 4 W !,"This report lists Open Purchase Card Transactions created in the" … … 23 23 EXIT I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20 24 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) ,PRCIEND ^%ZISC25 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 26 K CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS,INIC,INIB 27 27 Q … … 41 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 42 E W "encrypted" 43 S RD=$P(^RMPR(664,RP,0),U,1) ,PRCIEN=$P(^RMPR(664,RP,4),U,6)43 S RD=$P(^RMPR(664,RP,0),U,1) 44 44 S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7) 45 W ?36,RD I PRCIEN,($P($G(^PRC(442,PRCIEN,7)),U)=45) W "#"45 W ?36,RD 46 46 W ?43,$P(^RMPR(664,RP,4),U,5) 47 47 W ?50 … … 69 69 HDR I PAGE'=1!($E(IOST)["C") W @IOF 70 70 I $E(IOST)["C" W @IOF G EXIT:X="^" 71 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! ,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",!S PAGE=PAGE+1 Q71 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! S PAGE=PAGE+1 Q -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4OPN.m
r628 r636 1 1 RMPR4OPN ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,20 ,140**;Feb 09, 1996;Build 102 ;;3.0;PROSTHETICS;**3,20**;Feb 09, 1996 3 3 W !,"This report lists Open Purchase Card Transactions created in the" 4 4 W !,"Prosthetics Package." … … 18 18 EXIT I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20 19 19 I $D(RMPREDT),'$D(DTOUT),'$D(DUOUT),$E(IOST)["C",'$D(RMPRFLL),RMPREND'=1 S DIR(0)="E" D ^DIR 20 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 ^%ZISC20 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 21 21 K CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS 22 22 Q … … 36 36 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) 37 37 E W "encrypted" 38 S RD=$P(^RMPR(664,RP,0),U,1) ,PRCIEN=$P(^RMPR(664,RP,4),U,6)38 S RD=$P(^RMPR(664,RP,0),U,1) 39 39 S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7) 40 W ?36,RD I PRCIEN,($P($G(^PRC(442,PRCIEN,7)),U)=45) W "#"40 W ?36,RD 41 41 W ?43,$P(^RMPR(664,RP,4),U,5) 42 42 W ?50 … … 59 59 Q 60 60 HDR I PAGE'=1!($E(IOST)["C") W @IOF 61 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! ,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",!S PAGE=PAGE+1 Q61 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! S PAGE=PAGE+1 Q -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P21.m
r628 r636 1 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 42 ;;3.0;PROSTHETICS;**3,15,19,26,55,90,132,133**;Feb 09, 1996;Build 2 3 3 ; 4 4 ; ODJ - patch 55 - 1/29/01 - replace hard code mail route symbol 121 … … 63 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 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" 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" 67 66 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 68 67 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR8PG.m
r628 r636 1 1 RMPR8PG ;PHX,HOIFO/JLT,SPS-PURGE 668 SUSPENSE FILE ;8/29/1994 2 ;;3.0;PROSTHETICS;**5,75 ,140**;Feb 09, 1996;Build 102 ;;3.0;PROSTHETICS;**5,75**;Feb 09, 1996;Build 25 3 3 ; 4 4 ;02/03/06 Added code to delete the pointer in 664.1 field .05 when a … … 14 14 S DIS(0)="I $P(^RMPR(668,D0,0),U,7)=RMPR(""STA"")",IOP=ION,DIC="^RMPR(668,",FLDS=".01;C1,1;C20;L17,2,3,6;C45;L15,5;C65,4;C1,7;C1",BY="5",FR=$S($D(^RMPR(668,"B")):$O(^RMPR(668,"B","")),1:2890101) 15 15 S TO=RMPRDT,DHD="Purge Suspense File Entries from Station/Division "_RMPR("STA") D EN1^DIP 16 N RMPR664117 16 F S RMPRIEN=$O(^RMPR(668,RMPRIEN)) Q:RMPRIEN'>0 I $P($G(^RMPR(668,RMPRIEN,0)),U,7)=RMPR("STA") I ($P(^RMPR(668,RMPRIEN,0),U,5))&($P(^(0),U,5)<RMPRDT) S DA=RMPRIEN,DIC="^RMPR(668," S DA=RMPRIEN,DIK=DIC D ^DIK D S RDEL=RDEL+1 18 . S RMPR6641=0F S RMPR6641=$O(^RMPR(664.1,"SUS",DA,RMPR6641)) Q:RMPR6641'>0 D17 . F S RMPR6641=$O(^RMPR(664.1,"SUS",DA,RMPR6641)) Q:RMPR6641'>0 D 19 18 .. I $D(^RMPR(664.1,RMPR6641,0)) S $P(^(0),U,8)="" 20 19 END I $G(RDEL)<1 W !!,"No Suspense entries purged." … … 22 21 I $G(RDEL)=1 W !!,RDEL,"Suspense entry purged. " 23 22 EXIT ;common exit point 24 K I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,R MPR6641,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO D ^%ZISC Q23 K I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO D ^%ZISC Q -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9CA.m
r628 r636 1 1 RMPR9CA ;OI-HINES/HNC -SUSPENSE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**90 ,135,141**;Feb 09, 1996;Build 52 ;;3.0;PROSTHETICS;**90**;Feb 09, 1996 3 3 A1 ;roll and scroll entry point 4 4 G A2 … … 137 137 F S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT="" D 138 138 .S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0) 139 D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ)139 S RMGMRCO=$$RC^GMRCGUIA(.GMRCO,DUZ,RMPREODT,.GMRCMT,DUZ) 140 140 K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT 141 141 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING." … … 190 190 Q 191 191 UPD ;update file 668 with 2319 records 192 S DA(1)=RMIE68 K DD,DO,DIC192 S DA(1)=RMIE68 193 193 S DIC="^RMPR(668,"_DA(1)_","_"10," 194 194 S DIC(0)="L",DLAYGO=668,X=RMIE60 195 195 D FILE^DICN 196 K X,DD,DO,DIC 197 S DA(1)=RMIE68,DIC(0)="L",DLAYGO=668 196 S DA(1)=RMIE68 198 197 S DIC="^RMPR(668,"_DA(1)_","_"11," 199 198 S X=RMAMIS 200 199 D FILE^DICN 201 K DIC,X,DLAYGO ,DD,DO200 K DIC,X,DLAYGO 202 201 Q 203 202 A3 G A4 -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9DO.m
r628 r636 1 1 RMPR9DO ;HOIFO/HNC - ORDER CONROL PROCESSING-REMOTE PROCEDURE ;9/8/03 07:12 2 ;;3.0;PROSTHETICS;**59,77,90,60 ,135**;Feb 09, 1996;Build 122 ;;3.0;PROSTHETICS;**59,77,90,60**;Feb 09, 1996;Build 18 3 3 ; 4 4 ;8/5/03 Make sure no dups, HNC patch 77 … … 175 175 ;PPD=1 for previous pending 176 176 I ADATE'="" S (PDAY,WRKDAY)=$$WRKDAY^RMPREOU(RMPRA) 177 I ADATE="" S (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA) I $P(^RMPR(668,RMPRA,0),U,10)="X" S (PDAY,WRKDAY)=$$CANWKDY^RMPREOU(RMPRA)177 I ADATE="" S (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA) 178 178 I ADATE'="" S CDAY=$$PDAY^RMPREOU(RMPRA) 179 ;180 179 S STATUS=$$STATUS^RMPREOU(RMPRA) 181 180 I STATUS["PENDING" D -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9P21.m
r628 r636 1 1 RMPR9P21 ;PHX/SPS,HNC,RVD -SEND DATA TO PC TO PRINT PURCHASE CARD ORDER ;4/27/05 2 ;;3.0;PROSTHETICS;**90,116,119,133 ,139**;Feb 09, 1996;Build 42 ;;3.0;PROSTHETICS;**90,116,119,133**;Feb 09, 1996;Build 2 3 3 ; 4 4 EN(RMPRA,RMPRSITE,RMPRPTR) ;ENTRY POINT FOR VISTA ROLL AND SCROLL … … 67 67 I VAPA(2)'="" S ^TMP($J,"RMPRPRT",CNT+10)=" "_VAPA(8)_SPACE_"CHARGE MEDICAL APPROPRIATION" 68 68 S ^TMP($J,"RMPRPRT",CNT+11)=RMPRB 69 S ^TMP($J,"RMPRPRT",CNT+12)="7. Claim Number 69 S ^TMP($J,"RMPRPRT",CNT+12)="7. Claim Number "_VAEL(7)_" 8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3) 70 70 S ^TMP($J,"RMPRPRT",CNT+13)=RMPRB 71 71 S ^TMP($J,"RMPRPRT",CNT+14)="10. Statistical Data 11. FOB Point 12. Discount 13. Delivery Time" -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRD1.m
r628 r636 1 1 RMPRD1 ;PHX/HNB-DISPLAY LOOKUP ;10/19/1993 [ 06/28/94 3:17 PM ]<<= NOT VERIFIED > 2 ;;3.0;PROSTHETICS;**38 ,141**;Feb 09, 1996;Build 52 ;;3.0;PROSTHETICS;**38**;Feb 09, 1996 3 3 EN ;DISPLAY DATE,PATIENT,ITEM,COST FROM 660 4 4 S Z=^RMPR(660,+Y,0) … … 22 22 .F S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0 D 23 23 ..S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1) Q:$G(RMPRI1)'>0 24 ..S RMPRIT=$P( $G(^RMPR(661,RMPRI1,0)),U,1)25 ..S :RMPRIT RMPRN=$P(^PRC(441,RMPRIT,0),U,2) S:RMPRIT="" RMPRN="*MASTER ITEM DELETED*"24 ..S RMPRIT=$P(^RMPR(661,RMPRI1,0),U,1) 25 ..S RMPRN=$P(^PRC(441,RMPRIT,0),U,2) 26 26 ..W ?64,$E(RMPRN,1,15) 27 27 ..I $O(^RMPR(664,+Y,1,RMPRI)) W ! -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRDDC.m
r628 r636 1 1 RMPRDDC ;VACO/HNC - SERVER ROUTINE FOR DALC RECORD IN 660 ; 11/01/2006 2 ;;3.0;PROSTHETICS;**60 ,141**;Feb 09, 1996;Build 52 ;;3.0;PROSTHETICS;**60**;Feb 09, 1996;Build 18 3 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 4 ; … … 9 9 ;loop msg 10 10 K RMPRMSG 11 N ERR12 11 S RMPRCNT=0 13 12 S RMPRMSGC=0 … … 51 50 .; RMPRDAT,U,21 IS RESERVED FOR A RETURN NUMBER TBD SKIPPED 52 51 .S RMPROS=$P($G(RMPRDATA),U,22) ;ordering station 53 .S RMPRSTA=$$FIND1^DIC(4,"","X",RMPROS,"D","","ERR")54 .I $D(ERR)!(RMPRSTA'>0) D55 .. S RMPR6699=$O(^RMPR(669.9,0)),RMPRSTA=$P(^RMPR(669.9,RMPR6699,0),U,2)56 52 .S X=$P($G(RMPRDATA),U,20) ;return date 57 53 .S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,3,4) D ^%DT S RMPRRT=Y … … 114 110 K RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF 115 111 K RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN,RMPR(660),RMPRCNT,RMPRDATA 116 K RMPRFLG,RMPROUT,RMPRNAM,RMPRWHN,RMPRMSGC,RMPRPNAM,RMPRNPMN ,RMPRSTA,RMPR6699112 K RMPRFLG,RMPROUT,RMPRNAM,RMPRWHN,RMPRMSGC,RMPRPNAM,RMPRNPMN 117 113 ;purge server message 118 114 S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOS.m
r628 r636 1 1 RMPREOS ;HINES-CIOFO/HNC -Suspense Processing ; 2/25/04 10:26am 2 ;;3.0;PROSTHETICS;**45,50,52,55,57,62,80,85,97 ,135**;Feb 09, 1996;Build 122 ;;3.0;PROSTHETICS;**45,50,52,55,57,62,80,85,97**;Feb 09, 1996 3 3 ; 4 4 ; HNC - patch 52 - 9/22/00 Modify EN2 not to check for RMPRFLAG … … 72 72 S GMRCO=$P(^RMPR(668,DA,0),U,15) Q:GMRCO="" 73 73 ;note in array 74 S RMPRCMT=0 ,GMRCMT=174 S RMPRCMT=0 75 75 F S RMPRCMT=$O(^RMPR(668,DA,3,RMPRCMT)) Q:RMPRCMT="" D 76 76 .S GMRCMT(RMPRCMT)=^RMPR(668,DA,3,RMPRCMT,0) 77 I $G(GMRCMT (1))="" S GMRCMT(1)="nothing noted"77 I $G(GMRCMT)="" S GMRCMT="nothing noted" 78 78 ;call api 79 D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ)79 S RMGMRCO=$$RC^GMRCGUIA(.GMRCO,DUZ,RMPREODT,.GMRCMT,DUZ) 80 80 K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT 81 81 Q -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOU.m
r628 r636 1 1 RMPREOU ;HINES/HNC -Suspense Processing Utility ;2-2-2000 2 ;;3.0;PROSTHETICS;**45,55,59 ,135**;Feb 09, 1996;Build 122 ;;3.0;PROSTHETICS;**45,55,59**;Feb 09, 1996 3 3 ; Add new function for working days M-F. 4 4 Q … … 104 104 D WDAY 105 105 Q RMTO 106 CANWKDY(DA) ;*135 working days between create and cancel date for cancel w/o initial action records.107 ;holidays are counted as working days108 ;parm 1=ien 668, DA109 N RMTO,RB,RE110 S RB=$P($G(^RMPR(668,DA,0)),U)111 Q:RB="" 0112 S RE=$P(^RMPR(668,DA,5),U)113 Q:RE="" 0114 D WDAY115 Q RMTO116 106 WDAY ; RB - begining date 117 107 ; RE - ending date -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRP21.m
r628 r636 1 1 RMPRP21 ;PHX/RFM-PRINT 10-2421 ;8/29/1994 2 ;;3.0;PROSTHETICS;**3,19,55,90,129,133 ,139**;Feb 09, 1996;Build 42 ;;3.0;PROSTHETICS;**3,19,55,90,129,133**;Feb 09, 1996;Build 2 3 3 ; 4 4 ; ODJ - patch 55 - 1/29/01 - extrinsic to get mail routing code … … 6 6 ; nois AUG-1097-32118 7 7 ; 8 I '$D(RMPR) !'$D(RMPRSITE)D DIV4^RMPRSIT Q:$D(X)8 I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X) 9 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 10 I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS … … 15 15 S DIC("W")="D EN2^RMPRD1" D ^DIC G:Y<0 EX S RMPRA=+Y I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM 16 16 D PR^RMPR21A I %'>0 G EX 17 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 PT17 ;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 18 18 ZIS S %ZIS="QM" D ^%ZIS G:POP EX 19 19 I '$D(IO("Q")) U IO G PRT … … 23 23 PRT ;ENTRY POINT TO PRINT 2421S 24 24 S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y 25 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),CP=$P( $G(^PRCS(410,CP,0)),U,1),RMPRPAGE=225 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),CP=$P(^PRCS(410,CP,0),U,1),RMPRPAGE=2 26 26 D ADD^VADPT,DEM^VADPT,ELIG^VADPT 27 27 W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: " … … 59 59 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" 60 60 W !,RMPRB 61 ;Remove claim number print in *139 since it held SSN at times 62 W !,"7. Claim Number",?40,"8. SSN"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time" 61 W !,"7. Claim Number"_" "_VAEL(7),?40,"8. SSN"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time" 63 62 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 64 63 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") S SPE=$P(R664(1,R664("E"),0),U,11) -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPAT2.m
r628 r636 1 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;Build53 D HDR N RMPRMERG S RMPRMERG=02 ;;3.0;PROSTHETICS;**32,34,29,44,99,75**;Feb 09, 1996;Build 25 3 D HDR 4 4 S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT 5 5 MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN) 6 ;Check for merged accounts7 I $D(^XDRM("B",RMPRDFN_";DPT(")) D8 . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""9 . S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=010 . MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRMERG)11 6 S B=0 12 7 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D … … 21 16 . .S ^TMP($J,"AG",GN,ND,BC)=B 22 17 S B="" 23 F S B=$O(^TMP($J,"AG",B)) Q: +B=0 D18 F S B=$O(^TMP($J,"AG",B)) Q:B'>0 D 24 19 .S BC="" 25 20 .F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCEB.m
r628 r636 1 1 RMPRPCEB ;HIN/RVD-PROS PCE BACKGROUND UTILITY ; 1/23/04 8:09am 2 ;;3.0;PROSTHETICS;**62,69,77,82,78,114,120,133 ,142**;Feb 09, 1996;Build 22 ;;3.0;PROSTHETICS;**62,69,77,82,78,114,120,133**;Feb 09, 1996;Build 2 3 3 ; 4 4 ;RVD patch #69 - add STATION in the error message. … … 27 27 F S RI=$O(^RMPR(660,RI)) Q:RI'>0 D 28 28 .S RM600=$G(^RMPR(660,RI,0)) 29 .I $P(RM600,U,2)="" Q30 29 .S RM611=$G(^RMPR(660,RI,1)) 31 30 .S RM610=$G(^RMPR(660,RI,10)) -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCED.m
r628 r636 1 1 RMPRPCED ;Hines OIFO/RVD - Prosthetics/660/668/PCE DELETE ;7/30/02 09:39 2 ;;3.0;PROSTHETICS;**62,70,121,131 ,141**;Feb 09, 1996;Build 52 ;;3.0;PROSTHETICS;**62,70,121,131**;Feb 09, 1996;Build 3 3 3 ;RVD 7/1/02 - patch #70 - new RMPR variables before calling PCE. 4 4 ; … … 52 52 .S RMAMIS68=$G(^RMPR(660,I,"AMS")) S:RMAMIS68=RMAMIS RMCNT=RMCNT+1 53 53 ;if no other line item of the same GROUPER #, then delete. 54 I RMCNT=1 ,RMAMIEND54 I RMCNT=1 D 55 55 .S DA=RMAMIEN 56 56 .S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",11," -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m
r628 r636 1 1 RMPRPIY7 ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/18/02 15:17 2 ;;3.0;PROSTHETICS;**61,118 ,139**;Feb 09, 1996;Build 42 ;;3.0;PROSTHETICS;**61,118**;Feb 09, 1996 3 3 ; 4 4 ;DBIA # 800 - FILEMAN read of file #440. … … 21 21 S RMPR5("IEN")="" 22 22 LOCNM1 D ^DIR 23 ;Patch *139 removes upper case translation to allow access to lower 24 ;case entries used in location creation option 25 ;S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 23 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 26 24 I $G(RMPR5("IEN"))'="" S RMPREXC="" G LOCNMX 27 25 I $D(DTOUT) S RMPREXC="T" G LOCNMX -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYF.m
r628 r636 1 1 RMPRPIYF ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/2/02 07:27 2 ;;3.0;PROSTHETICS;**61,117 ,139**;Feb 09, 1996;Build 42 ;;3.0;PROSTHETICS;**61,117**;Feb 09, 1996 3 3 ; RVD #61 - phase III of PIP enhancement. 4 4 ; … … 75 75 ; 76 76 DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK 77 ;** MOVED TO RMPRPIFD DUE TO SIZE CONSTRAINTS 78 G DEL1^RMPRPIFD 77 K DIR 78 S DIR("A")="Are you sure you want to DELETE this entry",DIR("B")="N",DIR(0)="Y" 79 D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) G EXIT 80 I Y'=1 G CO^RMPRPIYE 81 ; 82 DEL2 ;call API for returning item to PIP 83 S (RMCHK,RMERPCE)=0 84 S RMI68=$P($G(^RMPR(660,RMPRIEN,10)),U,1) I RMI68>0 D I RMERPCE W !!,"** STOCK ISSUE DELETE ABORTED",!! G EXIT 85 .S RMCHK=$$DEL^RMPRPCED(RMPRIEN) 86 .I RMCHK'=0 W !!,"*** ERROR in PCE DELETE, Please notify your IRM..660 IEN = ",RMPRIEN,!! S RMERPCE=1 H 3 87 S RMPR60("IEN")=RMPRIEN 88 S RMCHK=$$DEL^RMPRPIU3(.RMPR60) 89 I $G(RMCHK) W !,"*** Error in API RMPRPIU3, ERROR = ",RMCHK,!,"*** Please inform your IRM !!",! G EXIT 90 ; 91 W $C(7),!?10,"Deleted..." H 1 79 92 EXIT ;KILL VARIABLES AND EXIT ROUTINE 80 93 I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN) -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPRT1.m
r628 r636 1 1 RMPRPRT1 ;PHX/HNB-CONTINUATION OF PRINT 2319 ;10/19/1993 2 ;;3.0;PROSTHETICS;**10,99 ,137,141**;Feb 09, 1996;Build 52 ;;3.0;PROSTHETICS;**10,99**;Feb 09, 1996 3 3 ;CALLED BY END^RMPRPRT 4 4 ;VARIABLES REQUIRED: R5 - A STRING ARRAY HOLDING PATIENT'S PROSTHETIC 5 5 ; DISABILITY CODE INFORMATION 6 N RMPRMERG S RMPRMERG=07 I $D(^XDRM("B",RMPRDFN_";DPT(")) D8 . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""9 . S RMPRMERG=+^XDRM(RMPRMERG,0)10 6 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 11 7 W !!,"PSC Issue Card: " S J=0 W ! … … 47 43 S RA="" 48 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 49 S RA=""50 I RMPRMERG D51 . 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^RMPRPRT52 45 I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! 53 46 E W !!,"End of Appliance/Repair records for this veteran!",!!," *Historical Item" … … 82 75 K RMPRLPRO 83 76 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)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) 85 78 W:REM]"" !,?5,"REMARKS: ",REM I $Y+6>IOSL D HDR^RMPRPRT,HDRH 86 79 S (DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM)="" -
FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSP7.m
r628 r636 1 1 RMPRSP7 ;HIN/RVD-PRINT 2319 WITHOUT SUSPENSE LINK ;3/17/03 08:13 2 ;;3.0;PROSTHETICS;**62,69,77 ,135**;Feb 09, 1996;Build 122 ;;3.0;PROSTHETICS;**62,69,77**;Feb 09, 1996 3 3 ;RVD 8/27/01 patch #62 - PCE data print 4 4 ;RVD 4/9/02 patch #69 - Disregard Historical data 5 5 ;RVD 3/17/02 patch #77 - Fixed For Loop to include all PT 2319 records 6 6 ; that are not linked 7 ;RGB 3/22/07 patch 135 - Modified code to check issues in 660 against file 668 suspense records8 ; in addition to current check of complete flag in issue record.9 7 ; 10 8 D DIV4^RMPRSIT I $D(Y),(Y<0) Q … … 48 46 .Q:($P(RM0,U,13)=13)!($P(RM0,U,15)="*") 49 47 .Q:($P(RM10,U,14)>0)!($P(RM0,U,10)'=RMPR("STA")) 50 .;FILTER SHIPPING CHARGES AND DDC TRANSACTIONS 51 .Q:($P(RM0,U,17)'="")!($P(RM0,U,13)=16) 52 .S RMIE68=$O(^RMPR(668,"F",RJ,0)) 53 .I RMIE68,$D(^RMPR(668,RMIE68,10,"B",RJ)) Q 48 .Q:$P(RM0,U,17)'="" 54 49 .I $P(RM0,U,10)=RS D 55 50 ..S RMDFN=$P(RM0,U,2)
Note:
See TracChangeset
for help on using the changeset viewer.
