source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29R.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1RMPR29R ;PHX/JLT,RVD-PRINT 2529-3 [ 10/01/94 5:39 AM ]
2 ;;3.0;PROSTHETICS;**9,23,34,75**;Feb 09, 1996;Build 25
3 ;get basic info, system variables
4 D DIV4^RMPRSIT G:$D(X) EXIT
5 K DIC S DIC=664.1,DIC(0)="AEQMZ"
6 S DIC("A")="Select Patient Name or Date: "
7 S DIC("S")="I $P(^(0),U,3)=RMPR(""STA"")&($P(^(0),U,17)'=""D""&($P(^(0),U,17)'=""C""))"
8 S DIC("W")="D EN3^RMPRD1"
9 D ^DIC G:+Y'>0 EXIT S RMPRDA=+Y K DIC D PRT,EXIT Q
10EN1(RMPRPTR) ;
11PRT ;PRINT 2529-3 PASS RMPRDA
12 ;CALLED BY RMPR29,RMPR29T
13 ;REQUIRED VARIABLES: RMPRDA - ENTRY NUMBER IN FILE 664.1
14 ; RMPRSITE - SITE OFSTATION PROCESSING 2529-3
15 S DIC=4,DIC(0)="QXZN",X=$P(^RMPR(664.1,RMPRDA,0),U,15)
16 D ^DIC G:+Y'>0 EXIT
17 K IOP,X N RC
18 S RMPRINS=+Y,RC=0
19 S RMPRST=$S($D(^DIC(5,+$P(Y(0),U,2),0)):$P(^(0),U),1:"")
20 I $D(^DIC(4,RMPRINS,1)) S RMPRAD(1)=$P(^(1),U,1),RMPRAD(2)=$P(^(1),U,2),RMPRCT=$P(^(1),U,3),RMPR9P=$P(^(1),U,4)
21 S DIOBEG="S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2),VAPA(""P"")=1,VAHOW=2 D ALL^VADPT"
22 D:'$D(IOP) GETP
23 ;
24 I $P(^RMPR(664.1,RMPRDA,0),U,11)="N" N RMPRFCTR D
25 .;national footwear center address in RMPRFCTR array used in print
26 .;template RMPR 25293
27 .S RMPRFCTR(1)="179TH ST & LINDEN BLVD."
28 .S RMPRFCTR(2)="ST. ALBANS, NY 11425"
29 ;
30 S L=0,DIC="^RMPR(664.1,",FLDS="[RMPR 25293]",BY="@NUMBER",(FR,TO)=RMPRDA D EN1^DIP D KVAR^VADPT Q
31EXIT ;common exit point
32 K RMPRINS,RMPRST,RMPRAD,DIC,BY,DFN,DIOBEG,DIOEND,FLDS,FR,IOP,L,PNODE
33 K RA,RB,RFL,RMPRCT,RMPRI,RMPRSC,RMPRWO,RMPR9P,SRC,TO,X,Y
34 Q
35INQ ;INQUIRE 2529-3 STATUS
36 D DIV4^RMPRSIT G:$D(X) EXIT
37 K DIC,DIR
38 S DIC=664.1,DIC(0)="AEQMZ"
39 S DIC("S")="I $P(^(0),U,3)=RMPR(""STA"")"
40 S DIC("W")="D EN3^RMPRD1" D ^DIC G:+Y'>0 EXIT S RMPRDA=+Y
41 S L=0,DIC="^RMPR(664.1,",FLDS="[RMPR 2529-3 STATUS]"
42 S BY="@NUMBER",(FR,TO)=RMPRDA
43 S DIOEND="I IOST[""C"" X ""I $Y<21 F W ! Q:$Y>21"" S DIR(0)=""E"" D ^DIR K DIR"
44 D EN1^DIP G EXIT
45STAT ;DISPLAY STATUS 2529-3
46 D:'$D(RMPR) DIV4^RMPRSIT Q:$D(X)
47 S STA=$G(DUZ(2))
48 I $D(^XUSEC("RMPR LAB MENU",DUZ)) S RP=0 D I RP>0 W !!,?5,$C(7),"There are '"_RP_"' 2529-3's Pending Assignment"
49 .F RI=0:0 S RI=$O(^RMPR(664.1,"E","P",RI)) Q:RI'>0 I $D(^RMPR(664.1,RI,0)),$P(^(0),U,3)=STA S RP=RP+1
50 I $D(^XUSEC("RMPR LAB MENU",DUZ)) S RP=0 D I RP>0 W !!,?5,$C(7),"There are '"_RP_"' 2529-3's that have been Returned"
51 .F RI=0:0 S RI=$O(^RMPR(664.1,"E","R",RI)) Q:RI'>0 I $D(^RMPR(664.1,RI,0)),$P(^(0),U,3)=STA S RP=RP+1
52 I $D(^XUSEC("RMPR LAB SUPERVISOR",DUZ)) S RP=0 D I RP>0 W !!,?5,$C(7),"There are '"_RP_"' Local 2529-3's Pending Completion"
53 .F RI=0:0 S RI=$O(^RMPR(664.1,"E","PC",RI)) Q:RI'>0 I $D(^RMPR(664.1,RI,0)),$P(^(0),U,3)=STA,$P(^(0),U,15)=STA S RP=RP+1
54 S (RP,RI)=0
55 I $D(^XUSEC("RMPR LAB MENU",DUZ)) S RP=0 D I RP>0 W !!,?5,$C(7),"There are '"_RP_"' Remote 2529-3's Pending Completion"
56 .;count remote pending
57 .F RI=0:0 S RI=$O(^RMPR(664.1,"E","PC",RI)) Q:RI'>0 I $D(^RMPR(664.1,RI,0)),$P(^(0),U,15)'=STA S RP=RP+1
58 I $D(^XUSEC("RMPR LAB MENU",DUZ)) S RP=0 D I RP>0 W !!,?5,$C(7),"There are '"_RP_"' Lab Stock Issue Pending Completion"
59 .F RI=0:0 S RI=$O(^RMPR(664.1,"E","S",RI)) Q:RI'>0 I $D(^RMPR(664.1,RI,0)),$P(^(0),U,3)=STA,$P(^(0),U,15)=STA S RP=RP+1
60 K RI,RP,STA Q
61ZDSP ;DISPLAY WORK ORDER LIST
62 F RMPRI=0:0 S RMPRI=$O(^RMPR(664.2,RMPRWO,1,RMPRI)) Q:RMPRI'>0 S RA=$P(^(RMPRI,0),U,1) I '$P(^(0),U,11) W !,?5,$$ITM1^RMPR31U(RA),?10,$$ITM^RMPR31U(RA)
63 I $D(RFL) D
64 .W ! S X="?",DIC="^RMPR(661,",DIC(0)="EQM"
65 .S DIC("S")="S RA=$P(^(0),U,1) I $D(^PRCP(445,""AE"",RA,PRCP(""I"")))&($P(^RMPR(664.1,RMPRDA,0),U,17)'=""D""&($P(^(0),U,17)'=""C""))"
66 .S DIC("W")="W ?10,$P(^PRC(441,$P(^(0),U,1),0),U,2)" D ^DIC K RFL
67 Q
68DSP ;DISPLAY 2529-3
69 ;CALLED BY RMPR29
70 ;REQUIRED VARIABLE: RMPRDA - ENTRY INF FILE 664.1
71 N DFN S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2) D DEM^VADPT
72 S L=0,DIC="^RMPR(664.1,",FLDS="[RMPR 2529 EDT]",BY="@NUMBER",(FR,TO)=RMPRDA,IOP="HOME" D EN1^DIP
73 Q
74LOC ;Display Request Location
75 ;CALLED BY RMPR29
76 ;REQUIRED VARIABLE: RMPRDA - ENTRY NUMBER IN FILE 664.1
77 S RB=^RMPR(664.1,RMPRDA,0),RMPRSC=$P(RB,U,11) K RB
78 S RA="O:ORTHOTIC LAB;R:RESTORATION LAB;S:SHOE LAST CLINIC;W:WHEELCHAIR REPAIR SHOP;N:NATIONAL FOOT CENTER;D:DDC;"
79 W !!,?5,"2529-3 Request Sent to ",$E($P($P(RA,RMPRSC_":",2),";",1),1,25)
80 Q
81GETP ;GET CORRECT PRINTER FOR 2529-3
82 ;ADDED PIECE 1 TO 669.9,DEV NODE FOR PRINTER FOR EYE CLINIC FOR 75
83 N SRC,PNODE S SRC=$P($G(^RMPR(664.1,RMPRDA,0)),U,11),PNODE=$P($G(^RMPR(669.9,RMPRSITE,"DEV")),U,1,99)
84 I $D(RMPRPTR),+RMPRPTR>0 S X=RMPRPTR
85 E S X=$S(SRC="N"!(SRC="D"):$P($G(^RMPR(669.9,RMPRSITE,0)),U,5),SRC="E":$P(PNODE,U),SRC="O":$P(PNODE,U,2),SRC="R":$P(PNODE,U,3),SRC="S":$P(PNODE,U,4),SRC="W":$P(PNODE,U,5),1:"")
86 ;see internal notes
87 S DIC="^%ZIS(1,",DIC(0)="NZ" D ^DIC I +Y>0 S IOP="Q;"_Y(0,0),DQTIME="NOW" W !!,$C(7),?5,"2529-3 Printout has been sent to Device "_Y(0,0),!!
88 Q
Note: See TracBrowser for help on using the repository browser.