RMPR29R ;PHX/JLT,RVD-PRINT 2529-3 [ 10/01/94 5:39 AM ]
;;3.0;PROSTHETICS;**9,23,34,75**;Feb 09, 1996;Build 25
;get basic info, system variables
D DIV4^RMPRSIT G:$D(X) EXIT
K DIC S DIC=664.1,DIC(0)="AEQMZ"
S DIC("A")="Select Patient Name or Date: "
S DIC("S")="I $P(^(0),U,3)=RMPR(""STA"")&($P(^(0),U,17)'=""D""&($P(^(0),U,17)'=""C""))"
S DIC("W")="D EN3^RMPRD1"
D ^DIC G:+Y'>0 EXIT S RMPRDA=+Y K DIC D PRT,EXIT Q
EN1(RMPRPTR) ;
PRT ;PRINT 2529-3 PASS RMPRDA
;CALLED BY RMPR29,RMPR29T
;REQUIRED VARIABLES: RMPRDA - ENTRY NUMBER IN FILE 664.1
; RMPRSITE - SITE OFSTATION PROCESSING 2529-3
S DIC=4,DIC(0)="QXZN",X=$P(^RMPR(664.1,RMPRDA,0),U,15)
D ^DIC G:+Y'>0 EXIT
K IOP,X N RC
S RMPRINS=+Y,RC=0
S RMPRST=$S($D(^DIC(5,+$P(Y(0),U,2),0)):$P(^(0),U),1:"")
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)
S DIOBEG="S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2),VAPA(""P"")=1,VAHOW=2 D ALL^VADPT"
D:'$D(IOP) GETP
;
I $P(^RMPR(664.1,RMPRDA,0),U,11)="N" N RMPRFCTR D
.;national footwear center address in RMPRFCTR array used in print
.;template RMPR 25293
.S RMPRFCTR(1)="179TH ST & LINDEN BLVD."
.S RMPRFCTR(2)="ST. ALBANS, NY 11425"
;
S L=0,DIC="^RMPR(664.1,",FLDS="[RMPR 25293]",BY="@NUMBER",(FR,TO)=RMPRDA D EN1^DIP D KVAR^VADPT Q
EXIT ;common exit point
K RMPRINS,RMPRST,RMPRAD,DIC,BY,DFN,DIOBEG,DIOEND,FLDS,FR,IOP,L,PNODE
K RA,RB,RFL,RMPRCT,RMPRI,RMPRSC,RMPRWO,RMPR9P,SRC,TO,X,Y
Q
INQ ;INQUIRE 2529-3 STATUS
D DIV4^RMPRSIT G:$D(X) EXIT
K DIC,DIR
S DIC=664.1,DIC(0)="AEQMZ"
S DIC("S")="I $P(^(0),U,3)=RMPR(""STA"")"
S DIC("W")="D EN3^RMPRD1" D ^DIC G:+Y'>0 EXIT S RMPRDA=+Y
S L=0,DIC="^RMPR(664.1,",FLDS="[RMPR 2529-3 STATUS]"
S BY="@NUMBER",(FR,TO)=RMPRDA
S DIOEND="I IOST[""C"" X ""I $Y<21 F W ! Q:$Y>21"" S DIR(0)=""E"" D ^DIR K DIR"
D EN1^DIP G EXIT
STAT ;DISPLAY STATUS 2529-3
D:'$D(RMPR) DIV4^RMPRSIT Q:$D(X)
S STA=$G(DUZ(2))
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"
.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
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"
.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
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"
.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
S (RP,RI)=0
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"
.;count remote pending
.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
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"
.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
K RI,RP,STA Q
ZDSP ;DISPLAY WORK ORDER LIST
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)
I $D(RFL) D
.W ! S X="?",DIC="^RMPR(661,",DIC(0)="EQM"
.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""))"
.S DIC("W")="W ?10,$P(^PRC(441,$P(^(0),U,1),0),U,2)" D ^DIC K RFL
Q
DSP ;DISPLAY 2529-3
;CALLED BY RMPR29
;REQUIRED VARIABLE: RMPRDA - ENTRY INF FILE 664.1
N DFN S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2) D DEM^VADPT
S L=0,DIC="^RMPR(664.1,",FLDS="[RMPR 2529 EDT]",BY="@NUMBER",(FR,TO)=RMPRDA,IOP="HOME" D EN1^DIP
Q
LOC ;Display Request Location
;CALLED BY RMPR29
;REQUIRED VARIABLE: RMPRDA - ENTRY NUMBER IN FILE 664.1
S RB=^RMPR(664.1,RMPRDA,0),RMPRSC=$P(RB,U,11) K RB
S RA="O:ORTHOTIC LAB;R:RESTORATION LAB;S:SHOE LAST CLINIC;W:WHEELCHAIR REPAIR SHOP;N:NATIONAL FOOT CENTER;D:DDC;"
W !!,?5,"2529-3 Request Sent to ",$E($P($P(RA,RMPRSC_":",2),";",1),1,25)
Q
GETP ;GET CORRECT PRINTER FOR 2529-3
;ADDED PIECE 1 TO 669.9,DEV NODE FOR PRINTER FOR EYE CLINIC FOR 75
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)
I $D(RMPRPTR),+RMPRPTR>0 S X=RMPRPTR
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:"")
;see internal notes
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),!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29R 4889 printed Apr 09, 2024@21:34:25 Page 2
RMPR29R ;PHX/JLT,RVD-PRINT 2529-3 [ 10/01/94 5:39 AM ]
+1 ;;3.0;PROSTHETICS;**9,23,34,75**;Feb 09, 1996;Build 25
+2 ;get basic info, system variables
+3 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+4 KILL DIC
SET DIC=664.1
SET DIC(0)="AEQMZ"
+5 SET DIC("A")="Select Patient Name or Date: "
+6 SET DIC("S")="I $P(^(0),U,3)=RMPR(""STA"")&($P(^(0),U,17)'=""D""&($P(^(0),U,17)'=""C""))"
+7 SET DIC("W")="D EN3^RMPRD1"
+8 DO ^DIC
if +Y'>0
GOTO EXIT
SET RMPRDA=+Y
KILL DIC
DO PRT
DO EXIT
QUIT
EN1(RMPRPTR) ;
PRT ;PRINT 2529-3 PASS RMPRDA
+1 ;CALLED BY RMPR29,RMPR29T
+2 ;REQUIRED VARIABLES: RMPRDA - ENTRY NUMBER IN FILE 664.1
+3 ; RMPRSITE - SITE OFSTATION PROCESSING 2529-3
+4 SET DIC=4
SET DIC(0)="QXZN"
SET X=$PIECE(^RMPR(664.1,RMPRDA,0),U,15)
+5 DO ^DIC
if +Y'>0
GOTO EXIT
+6 KILL IOP,X
NEW RC
+7 SET RMPRINS=+Y
SET RC=0
+8 SET RMPRST=$SELECT($DATA(^DIC(5,+$PIECE(Y(0),U,2),0)):$PIECE(^(0),U),1:"")
+9 IF $DATA(^DIC(4,RMPRINS,1))
SET RMPRAD(1)=$PIECE(^(1),U,1)
SET RMPRAD(2)=$PIECE(^(1),U,2)
SET RMPRCT=$PIECE(^(1),U,3)
SET RMPR9P=$PIECE(^(1),U,4)
+10 SET DIOBEG="S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2),VAPA(""P"")=1,VAHOW=2 D ALL^VADPT"
+11 if '$DATA(IOP)
DO GETP
+12 ;
+13 IF $PIECE(^RMPR(664.1,RMPRDA,0),U,11)="N"
NEW RMPRFCTR
Begin DoDot:1
+14 ;national footwear center address in RMPRFCTR array used in print
+15 ;template RMPR 25293
+16 SET RMPRFCTR(1)="179TH ST & LINDEN BLVD."
+17 SET RMPRFCTR(2)="ST. ALBANS, NY 11425"
End DoDot:1
+18 ;
+19 SET L=0
SET DIC="^RMPR(664.1,"
SET FLDS="[RMPR 25293]"
SET BY="@NUMBER"
SET (FR,TO)=RMPRDA
DO EN1^DIP
DO KVAR^VADPT
QUIT
EXIT ;common exit point
+1 KILL RMPRINS,RMPRST,RMPRAD,DIC,BY,DFN,DIOBEG,DIOEND,FLDS,FR,IOP,L,PNODE
+2 KILL RA,RB,RFL,RMPRCT,RMPRI,RMPRSC,RMPRWO,RMPR9P,SRC,TO,X,Y
+3 QUIT
INQ ;INQUIRE 2529-3 STATUS
+1 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+2 KILL DIC,DIR
+3 SET DIC=664.1
SET DIC(0)="AEQMZ"
+4 SET DIC("S")="I $P(^(0),U,3)=RMPR(""STA"")"
+5 SET DIC("W")="D EN3^RMPRD1"
DO ^DIC
if +Y'>0
GOTO EXIT
SET RMPRDA=+Y
+6 SET L=0
SET DIC="^RMPR(664.1,"
SET FLDS="[RMPR 2529-3 STATUS]"
+7 SET BY="@NUMBER"
SET (FR,TO)=RMPRDA
+8 SET DIOEND="I IOST[""C"" X ""I $Y<21 F W ! Q:$Y>21"" S DIR(0)=""E"" D ^DIR K DIR"
+9 DO EN1^DIP
GOTO EXIT
STAT ;DISPLAY STATUS 2529-3
+1 if '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+2 SET STA=$GET(DUZ(2))
+3 IF $DATA(^XUSEC("RMPR LAB MENU",DUZ))
SET RP=0
Begin DoDot:1
+4 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,"E","P",RI))
if RI'>0
QUIT
IF $DATA(^RMPR(664.1,RI,0))
IF $PIECE(^(0),U,3)=STA
SET RP=RP+1
End DoDot:1
IF RP>0
WRITE !!,?5,$CHAR(7),"There are '"_RP_"' 2529-3's Pending Assignment"
+5 IF $DATA(^XUSEC("RMPR LAB MENU",DUZ))
SET RP=0
Begin DoDot:1
+6 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,"E","R",RI))
if RI'>0
QUIT
IF $DATA(^RMPR(664.1,RI,0))
IF $PIECE(^(0),U,3)=STA
SET RP=RP+1
End DoDot:1
IF RP>0
WRITE !!,?5,$CHAR(7),"There are '"_RP_"' 2529-3's that have been Returned"
+7 IF $DATA(^XUSEC("RMPR LAB SUPERVISOR",DUZ))
SET RP=0
Begin DoDot:1
+8 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,"E","PC",RI))
if RI'>0
QUIT
IF $DATA(^RMPR(664.1,RI,0))
IF $PIECE(^(0),U,3)=STA
IF $PIECE(^(0),U,15)=STA
SET RP=RP+1
End DoDot:1
IF RP>0
WRITE !!,?5,$CHAR(7),"There are '"_RP_"' Local 2529-3's Pending Completion"
+9 SET (RP,RI)=0
+10 IF $DATA(^XUSEC("RMPR LAB MENU",DUZ))
SET RP=0
Begin DoDot:1
+11 ;count remote pending
+12 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,"E","PC",RI))
if RI'>0
QUIT
IF $DATA(^RMPR(664.1,RI,0))
IF $PIECE(^(0),U,15)'=STA
SET RP=RP+1
End DoDot:1
IF RP>0
WRITE !!,?5,$CHAR(7),"There are '"_RP_"' Remote 2529-3's Pending Completion"
+13 IF $DATA(^XUSEC("RMPR LAB MENU",DUZ))
SET RP=0
Begin DoDot:1
+14 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,"E","S",RI))
if RI'>0
QUIT
IF $DATA(^RMPR(664.1,RI,0))
IF $PIECE(^(0),U,3)=STA
IF $PIECE(^(0),U,15)=STA
SET RP=RP+1
End DoDot:1
IF RP>0
WRITE !!,?5,$CHAR(7),"There are '"_RP_"' Lab Stock Issue Pending Completion"
+15 KILL RI,RP,STA
QUIT
ZDSP ;DISPLAY WORK ORDER LIST
+1 FOR RMPRI=0:0
SET RMPRI=$ORDER(^RMPR(664.2,RMPRWO,1,RMPRI))
if RMPRI'>0
QUIT
SET RA=$PIECE(^(RMPRI,0),U,1)
IF '$PIECE(^(0),U,11)
WRITE !,?5,$$ITM1^RMPR31U(RA),?10,$$ITM^RMPR31U(RA)
+2 IF $DATA(RFL)
Begin DoDot:1
+3 WRITE !
SET X="?"
SET DIC="^RMPR(661,"
SET DIC(0)="EQM"
+4 SET 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""))"
+5 SET DIC("W")="W ?10,$P(^PRC(441,$P(^(0),U,1),0),U,2)"
DO ^DIC
KILL RFL
End DoDot:1
+6 QUIT
DSP ;DISPLAY 2529-3
+1 ;CALLED BY RMPR29
+2 ;REQUIRED VARIABLE: RMPRDA - ENTRY INF FILE 664.1
+3 NEW DFN
SET DFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
DO DEM^VADPT
+4 SET L=0
SET DIC="^RMPR(664.1,"
SET FLDS="[RMPR 2529 EDT]"
SET BY="@NUMBER"
SET (FR,TO)=RMPRDA
SET IOP="HOME"
DO EN1^DIP
+5 QUIT
LOC ;Display Request Location
+1 ;CALLED BY RMPR29
+2 ;REQUIRED VARIABLE: RMPRDA - ENTRY NUMBER IN FILE 664.1
+3 SET RB=^RMPR(664.1,RMPRDA,0)
SET RMPRSC=$PIECE(RB,U,11)
KILL RB
+4 SET RA="O:ORTHOTIC LAB;R:RESTORATION LAB;S:SHOE LAST CLINIC;W:WHEELCHAIR REPAIR SHOP;N:NATIONAL FOOT CENTER;D:DDC;"
+5 WRITE !!,?5,"2529-3 Request Sent to ",$EXTRACT($PIECE($PIECE(RA,RMPRSC_":",2),";",1),1,25)
+6 QUIT
GETP ;GET CORRECT PRINTER FOR 2529-3
+1 ;ADDED PIECE 1 TO 669.9,DEV NODE FOR PRINTER FOR EYE CLINIC FOR 75
+2 NEW SRC,PNODE
SET SRC=$PIECE($GET(^RMPR(664.1,RMPRDA,0)),U,11)
SET PNODE=$PIECE($GET(^RMPR(669.9,RMPRSITE,"DEV")),U,1,99)
+3 IF $DATA(RMPRPTR)
IF +RMPRPTR>0
SET X=RMPRPTR
+4 IF '$TEST
SET X=$SELECT(SRC="N"!(SRC="D"):$PIECE($GET(^RMPR(669.9,RMPRSITE,0)),U,5),SRC="E":$PIECE(PNODE,U),SRC="O":$PIECE(PNODE,U,2),SRC="R":$PIECE(PNODE,U,3),SRC="S":$PIECE(PNODE,U,4),SRC="W":$PIECE(PNODE,U,5),1:"")
+5 ;see internal notes
+6 SET DIC="^%ZIS(1,"
SET DIC(0)="NZ"
DO ^DIC
IF +Y>0
SET IOP="Q;"_Y(0,0)
SET DQTIME="NOW"
WRITE !!,$CHAR(7),?5,"2529-3 Printout has been sent to Device "_Y(0,0),!!
+7 QUIT
