- 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 Jan 18, 2025@03:33:35 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