RMPRSEA ;PHX/RFM-SEARCH FILE 660 ENTRIES FOR RECALLED ITEM ;8/29/1994
;;3.0;PROSTHETICS;**77,90**;Feb 09, 1996
;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
;HNC 10/29/04 #90 - ITEM to BILLING ITEM
D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT S RMPRCOUN=0,RMPREND="" W !! S %DT("A")="Beginning Date: ",%DT="AEPX" D ^%DT S RMPRBDT=Y G:Y<0 EXIT
ENDATE S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EXIT I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G ENDATE
G:Y<0 EXIT S RMPREDT=Y,Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y
K DIR S DIR(0)="S^1:Search by Serial Number or Lot Number;2:Search by Billing Item;" D ^DIR G:$D(DIRUT) EXIT S GOTO=$S(Y=1:"SERIAL",Y=2:"ITEM") D @GOTO G:$D(DIRUT) EXIT1
S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
I '$D(IO("Q")) U IO G PRINT
S ZTDESC="SEARCH FOR RECALLED ITEM",ZTRTN="PRINT^RMPRSEA",ZTIO=ION,ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRSE")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("GOTO")="",ZTSAVE("RMPR(""STA"")")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
PRINT S X1=RMPRBDT,X2=-1 D C^%DTC S RO=X,RP=0,PAGE=1,RMPRCOUN=0,RMPREND="" I $E(IOST)["C" D WAIT^DICD
PRI F J=0:0 S RO=$O(^RMPR(660,"B",RO)) Q:RO'>0!(RO>RMPREDT) Q:RMPREND=1 F K=0:0 S RP=$O(^RMPR(660,"B",RO,RP)) Q:RP'>0 Q:RMPREND=1 D CK G:$D(DUOUT) EXIT
I $D(RMPREDT),'POP,'RMPRCOUN W @IOF D HEAD W $C(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!"
I RMPRCOUN,$D(RMPREDT),RMPREND'=1 W !!?32,"END OF REPORT"
EXIT I IOST["C-"&($Y<22) F W ! Q:$Y>20
I $D(RMPREDT),IOST["C-",'$D(RMPRFLL),RMPREND'=1,'$D(DUOUT),'$D(DTOUT) K DIR S DIR(0)="E" D ^DIR
EXIT1 K GOTO,DIC,DIR,DIRUT,DTOUT,DUOUT,RMPREND,PAGE,RMPRFLL,RAUT,RPAT,LI,RO,RMPRCOUN,RMPRSE,RMPRBDT,RMPREDT,RMPRX,RMPRY,RP,Y,K,X,J D ^%ZISC
Q
CK Q:'$D(^RMPR(660,RP,0)) Q:$P(^(0),U,4)="X"!('$P(^(0),U,6)) Q:'$D(^PRC(441,$P(^RMPR(661,+$P(^(0),U,6),0),U)))
I GOTO["SERIAL",$P(^RMPR(660,RP,0),U,11)[RMPRSE!($P(^(0),U,24)[RMPRSE) D CON
I GOTO["ITEM",RMPRSE=$P(^PRC(441,$P(^RMPR(661,$P(^RMPR(660,RP,0),U,6),0),U),0),U) D CON
Q
CON I $Y>(IOSL-6),PAGE=1,'RMPRCOUN W @IOF
D HEAD S RMPRCOUN=RMPRCOUN+1
S Y=$P(^RMPR(660,RP,0),U,3) D DD^%DT W !,Y,?15,$E($P(^DPT($P(^RMPR(660,RP,0),U,2),0),U,1),1,13),?30,$E($P(^DPT($P(^RMPR(660,RP,0),U,2),0),U,9),6,9),?36,$E($P(^PRC(441,$P(^RMPR(661,$P(^RMPR(660,RP,0),U,6),0),U,1),0),U,2),1,17)
W:$P(^RMPR(660,RP,0),U,9)'="" ?55,$E($P(^PRC(440,$P(^RMPR(660,RP,0),U,9),0),U,1),1,25)
W !,"LOT NBR:",?10,$P(^RMPR(660,RP,0),U,24),?25,"SERIAL NBR:",?37,$P(^RMPR(660,RP,0),U,11),!
I IOST["C-"&($Y>(IOSL-6)) S DUOUT=1,DIR(0)="E" D ^DIR S:Y="" RMPREND=1 Q:Y="" S:Y<1 RMPRFLL=1 Q:Y<1 K DIR W @IOF D HEAD Q
I $Y>(IOSL-6) W @IOF D HEAD
Q
HEAD I $Y<2 W !,?10,"RECALLED ITEM REPORT" S Y=RMPRBDT D DD^%DT W ?39,Y_"-" S Y=RMPREDT D DD^%DT W Y_" "_"STA ",$$STA^RMPRUTIL_" "_"PAGE ",PAGE,!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"ITEM",?55,"VENDOR",! S PAGE=PAGE+1 Q
Q
AUT ;AUTOMOTIVE EQUIPMENT SEARCH
S RMPRCOUN=0,RMPREND="" W !! S %DT("A")="Beginning Date: ",%DT="AEPX" D ^%DT S RMPRBDT=Y G:Y<0 EXIT
S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EXIT I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G AUT
G:Y<0 EXIT S RMPREDT=Y,Y=RMPREDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y
S DIR(0)="F^1:20^K:$E(X)="" "" X",DIR("A")="Enter Serial Number" D ^DIR G:$D(DIRUT) EXIT S RMPRSE=X K DIR
S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
I '$D(IO("Q")) U IO G PRINTA
K IO("Q") S ZTDESC="SEARCH FOR RECALLED AUTO ITEM",ZTRTN="PRINTA^RMPRSEA",ZTIO=ION,ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRSE")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="" D ^%ZTLOAD G EXIT
PRINTA S X1=RMPRBDT,X2=-1 D C^%DTC S RO=X,RP=0,RMPRCOUN=0,PAGE=1,RMPREND="" D HDR
F J=0:0 S RO=$O(^RMPR(667.3,"B",RO)) Q:RO'>0 Q:RO>RMPREDT Q:RMPREND=1 F K=0:0 S RP=$O(^RMPR(667.3,"B",RO,RP)) Q:RP'>0 Q:RMPREND=1 D CK1 G:$D(DUOUT) EXIT
I RMPRCOUN=0 W !!,"NO SELECTION MADE DURING THIS DATE RANGE!!"
G EXIT
CK1 Q:'$D(^RMPR(667.3,RP,0)) G:$P(^RMPR(667.3,RP,0),U,6)[RMPRSE INF
Q
INF S RMPRCOUN=RMPRCOUN+1,Y=$P(^RMPR(667.3,RP,0),U,1) S RAUT=^(0),RPAT=$P(^RMPR(667,$P(RAUT,U,2),0),U,2)
D DD^%DT W !,Y,?15,$E($P(^DPT(RPAT,0),U,1),1,13),?30,$E($P(^DPT(RPAT,0),U,9),6,9),?36,$P(^RMPR(667.1,$P(RAUT,U,3),0),U,1)
W !,"VEHICLE ID# ",$P(^RMPR(667,$P(RAUT,U,2),0),U,1),?50,"SERIAL # ",$P(RAUT,U,6) S $P(LI,"-",IOM)="" W !,LI
I IOST?1"C-".E&($Y>(IOSL-4)) S DUOUT=1,DIR(0)="E" D ^DIR S:Y<1 RMPREND=1 Q:Y="" S:Y<1 RMPRFLL=1 Q:Y<1 K DIR D HDR Q
I $Y'>(IOSL-4) Q
HDR W @IOF,!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"ITEM",?70,"PAGE ",PAGE S $P(LI,"-",IOM)="",PAGE=PAGE+1 W !,LI
Q
SERIAL S DIR(0)="F^1:20",DIR("A")="Enter Serial Number or Lot Number" D ^DIR Q:$D(DIRUT) S RMPRSE=X K DIR
Q
ITEM S DIC="^RMPR(661,",DIC(0)="AEQM",DIC("A")="Select BILLING ITEM: " D ^DIC I Y<0 S DIRUT=1 Q
S RMPRSE=$P(Y,U,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSEA 4913 printed Oct 16, 2024@18:38:21 Page 2
RMPRSEA ;PHX/RFM-SEARCH FILE 660 ENTRIES FOR RECALLED ITEM ;8/29/1994
+1 ;;3.0;PROSTHETICS;**77,90**;Feb 09, 1996
+2 ;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
+3 ;HNC 10/29/04 #90 - ITEM to BILLING ITEM
+4 DO HOME^%ZIS
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
SET RMPRCOUN=0
SET RMPREND=""
WRITE !!
SET %DT("A")="Beginning Date: "
SET %DT="AEPX"
DO ^%DT
SET RMPRBDT=Y
if Y<0
GOTO EXIT
ENDATE SET %DT("A")="Ending Date: "
SET %DT="AEX"
DO ^%DT
if Y<0
GOTO EXIT
IF RMPRBDT>Y
WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
GOTO ENDATE
+1 if Y<0
GOTO EXIT
SET RMPREDT=Y
SET Y=RMPRBDT
DO DD^%DT
SET RMPRX=Y
SET Y=RMPREDT
DO DD^%DT
SET RMPRY=Y
+2 KILL DIR
SET DIR(0)="S^1:Search by Serial Number or Lot Number;2:Search by Billing Item;"
DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
SET GOTO=$SELECT(Y=1:"SERIAL",Y=2:"ITEM")
DO @GOTO
if $DATA(DIRUT)
GOTO EXIT1
+3 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT
+4 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+5 SET ZTDESC="SEARCH FOR RECALLED ITEM"
SET ZTRTN="PRINT^RMPRSEA"
SET ZTIO=ION
SET ZTSAVE("RMPRBDT")=""
SET ZTSAVE("RMPREDT")=""
SET ZTSAVE("RMPRSE")=""
SET ZTSAVE("RMPRX")=""
SET ZTSAVE("RMPRY")=""
SET ZTSAVE("GOTO")=""
SET ZTSAVE("RMPR(""STA"")")=""
+6 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT
PRINT SET X1=RMPRBDT
SET X2=-1
DO C^%DTC
SET RO=X
SET RP=0
SET PAGE=1
SET RMPRCOUN=0
SET RMPREND=""
IF $EXTRACT(IOST)["C"
DO WAIT^DICD
PRI FOR J=0:0
SET RO=$ORDER(^RMPR(660,"B",RO))
if RO'>0!(RO>RMPREDT)
QUIT
if RMPREND=1
QUIT
FOR K=0:0
SET RP=$ORDER(^RMPR(660,"B",RO,RP))
if RP'>0
QUIT
if RMPREND=1
QUIT
DO CK
if $DATA(DUOUT)
GOTO EXIT
+1 IF $DATA(RMPREDT)
IF 'POP
IF 'RMPRCOUN
WRITE @IOF
DO HEAD
WRITE $CHAR(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!"
+2 IF RMPRCOUN
IF $DATA(RMPREDT)
IF RMPREND'=1
WRITE !!?32,"END OF REPORT"
EXIT IF IOST["C-"&($Y<22)
FOR
WRITE !
if $Y>20
QUIT
+1 IF $DATA(RMPREDT)
IF IOST["C-"
IF '$DATA(RMPRFLL)
IF RMPREND'=1
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
KILL DIR
SET DIR(0)="E"
DO ^DIR
EXIT1 KILL GOTO,DIC,DIR,DIRUT,DTOUT,DUOUT,RMPREND,PAGE,RMPRFLL,RAUT,RPAT,LI,RO,RMPRCOUN,RMPRSE,RMPRBDT,RMPREDT,RMPRX,RMPRY,RP,Y,K,X,J
DO ^%ZISC
+1 QUIT
CK if '$DATA(^RMPR(660,RP,0))
QUIT
if $PIECE(^(0),U,4)="X"!('$PIECE(^(0),U,6))
QUIT
if '$DATA(^PRC(441,$PIECE(^RMPR(661,+$PIECE(^(0),U,6),0),U)))
QUIT
+1 IF GOTO["SERIAL"
IF $PIECE(^RMPR(660,RP,0),U,11)[RMPRSE!($PIECE(^(0),U,24)[RMPRSE)
DO CON
+2 IF GOTO["ITEM"
IF RMPRSE=$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^RMPR(660,RP,0),U,6),0),U),0),U)
DO CON
+3 QUIT
CON IF $Y>(IOSL-6)
IF PAGE=1
IF 'RMPRCOUN
WRITE @IOF
+1 DO HEAD
SET RMPRCOUN=RMPRCOUN+1
+2 SET Y=$PIECE(^RMPR(660,RP,0),U,3)
DO DD^%DT
WRITE !,Y,?15,$EXTRACT($PIECE(^DPT($PIECE(^RMPR(660,RP,0),U,2),0),U,1),1,13),?30,$EXTRACT($PIECE(^DPT($PIECE(^RMPR(660,RP,0),U,2),0),U,9),6,9),?36,$EXTRACT($PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^RMPR(660,RP,0),U,6),0),U,1),0),U,2),1,17)
+3 if $PIECE(^RMPR(660,RP,0),U,9)'=""
WRITE ?55,$EXTRACT($PIECE(^PRC(440,$PIECE(^RMPR(660,RP,0),U,9),0),U,1),1,25)
+4 WRITE !,"LOT NBR:",?10,$PIECE(^RMPR(660,RP,0),U,24),?25,"SERIAL NBR:",?37,$PIECE(^RMPR(660,RP,0),U,11),!
+5 IF IOST["C-"&($Y>(IOSL-6))
SET DUOUT=1
SET DIR(0)="E"
DO ^DIR
if Y=""
SET RMPREND=1
if Y=""
QUIT
if Y<1
SET RMPRFLL=1
if Y<1
QUIT
KILL DIR
WRITE @IOF
DO HEAD
QUIT
+6 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
+7 QUIT
HEAD IF $Y<2
WRITE !,?10,"RECALLED ITEM REPORT"
SET Y=RMPRBDT
DO DD^%DT
WRITE ?39,Y_"-"
SET Y=RMPREDT
DO DD^%DT
WRITE Y_" "_"STA ",$$STA^RMPRUTIL_" "_"PAGE ",PAGE,!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"ITEM",?55,"VENDOR",!
SET PAGE=PAGE+1
QUIT
+1 QUIT
AUT ;AUTOMOTIVE EQUIPMENT SEARCH
+1 SET RMPRCOUN=0
SET RMPREND=""
WRITE !!
SET %DT("A")="Beginning Date: "
SET %DT="AEPX"
DO ^%DT
SET RMPRBDT=Y
if Y<0
GOTO EXIT
+2 SET %DT("A")="Ending Date: "
SET %DT="AEX"
DO ^%DT
if Y<0
GOTO EXIT
IF RMPRBDT>Y
WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
GOTO AUT
+3 if Y<0
GOTO EXIT
SET RMPREDT=Y
SET Y=RMPREDT
DO DD^%DT
SET RMPRX=Y
SET Y=RMPREDT
DO DD^%DT
SET RMPRY=Y
+4 SET DIR(0)="F^1:20^K:$E(X)="" "" X"
SET DIR("A")="Enter Serial Number"
DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
SET RMPRSE=X
KILL DIR
+5 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT
+6 IF '$DATA(IO("Q"))
USE IO
GOTO PRINTA
+7 KILL IO("Q")
SET ZTDESC="SEARCH FOR RECALLED AUTO ITEM"
SET ZTRTN="PRINTA^RMPRSEA"
SET ZTIO=ION
SET ZTSAVE("RMPRBDT")=""
SET ZTSAVE("RMPREDT")=""
SET ZTSAVE("RMPRSE")=""
SET ZTSAVE("RMPRX")=""
SET ZTSAVE("RMPRY")=""
DO ^%ZTLOAD
GOTO EXIT
PRINTA SET X1=RMPRBDT
SET X2=-1
DO C^%DTC
SET RO=X
SET RP=0
SET RMPRCOUN=0
SET PAGE=1
SET RMPREND=""
DO HDR
+1 FOR J=0:0
SET RO=$ORDER(^RMPR(667.3,"B",RO))
if RO'>0
QUIT
if RO>RMPREDT
QUIT
if RMPREND=1
QUIT
FOR K=0:0
SET RP=$ORDER(^RMPR(667.3,"B",RO,RP))
if RP'>0
QUIT
if RMPREND=1
QUIT
DO CK1
if $DATA(DUOUT)
GOTO EXIT
+2 IF RMPRCOUN=0
WRITE !!,"NO SELECTION MADE DURING THIS DATE RANGE!!"
+3 GOTO EXIT
CK1 if '$DATA(^RMPR(667.3,RP,0))
QUIT
if $PIECE(^RMPR(667.3,RP,0),U,6)[RMPRSE
GOTO INF
+1 QUIT
INF SET RMPRCOUN=RMPRCOUN+1
SET Y=$PIECE(^RMPR(667.3,RP,0),U,1)
SET RAUT=^(0)
SET RPAT=$PIECE(^RMPR(667,$PIECE(RAUT,U,2),0),U,2)
+1 DO DD^%DT
WRITE !,Y,?15,$EXTRACT($PIECE(^DPT(RPAT,0),U,1),1,13),?30,$EXTRACT($PIECE(^DPT(RPAT,0),U,9),6,9),?36,$PIECE(^RMPR(667.1,$PIECE(RAUT,U,3),0),U,1)
+2 WRITE !,"VEHICLE ID# ",$PIECE(^RMPR(667,$PIECE(RAUT,U,2),0),U,1),?50,"SERIAL # ",$PIECE(RAUT,U,6)
SET $PIECE(LI,"-",IOM)=""
WRITE !,LI
+3 IF IOST?1"C-".E&($Y>(IOSL-4))
SET DUOUT=1
SET DIR(0)="E"
DO ^DIR
if Y<1
SET RMPREND=1
if Y=""
QUIT
if Y<1
SET RMPRFLL=1
if Y<1
QUIT
KILL DIR
DO HDR
QUIT
+4 IF $Y'>(IOSL-4)
QUIT
HDR WRITE @IOF,!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"ITEM",?70,"PAGE ",PAGE
SET $PIECE(LI,"-",IOM)=""
SET PAGE=PAGE+1
WRITE !,LI
+1 QUIT
SERIAL SET DIR(0)="F^1:20"
SET DIR("A")="Enter Serial Number or Lot Number"
DO ^DIR
if $DATA(DIRUT)
QUIT
SET RMPRSE=X
KILL DIR
+1 QUIT
ITEM SET DIC="^RMPR(661,"
SET DIC(0)="AEQM"
SET DIC("A")="Select BILLING ITEM: "
DO ^DIC
IF Y<0
SET DIRUT=1
QUIT
+1 SET RMPRSE=$PIECE(Y,U,2)
+2 QUIT
