RMPRSE1 ;PHX/RFM-SEARCH FILE 660 ENTRIES FOR ITEM HISTORY ;8/29/1994
;;3.0;PROSTHETICS;**20,57,77,90**;Feb 09, 1996
;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION.
; - use RMPR("STA") instead of $$STA^RMPRUTIL.
;
EN N ITEM,RMPRARR,RMPRI D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT1 S DIC="^RMPR(661,",DIC(0)="AEQM" F ITEM=1:1 S DIC("A")="Select ITEM "_ITEM_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(ITEM=1)) EXIT1 Q:X="" D
.I $D(RMPRI(+Y)) W $C(7)," ??",?40,"..Duplicate Item" S ITEM=ITEM-1 Q
.S RMPRARR(ITEM)=+Y,RMPRI(+Y)=""
S RMPRCOUN=0 W !! S %DT("A")="Beginning Date: ",%DT="AEPX",%DT("B")="T-30" D ^%DT S RMPRBDT=Y G:Y<0 EXIT1
ENDATE S %DT("A")="Ending Date: ",%DT="AEX",%DT("B")="TODAY" D ^%DT G:Y<0 EXIT1 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
S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="SEARCH FOR RECALLED ITEM",ZTRTN="PRINT^RMPRSE1",ZTIO=ION,ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRI(")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPRARR(")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
PRINT ;ENTRY POINT FOR PRINTING REPORT
S PAGE=1,(RMPRCOUN,RP,QTYT,COSTT)=0 I IOST["C-" D WAIT^DICD
PRI S RQ=0 F S RQ=$O(RMPRARR(RQ)) Q:RQ=""!($D(KILL)) S RO=$P(RMPRARR(RQ),U),RO=RO-1 D PRI1
G EXIT
PRI1 F S RO=$O(^RMPR(660,"AD",RO)) D:RO=""!(RO'=$P(RMPRARR(RQ),U)) REST Q:RO=""!(RO'=$P(RMPRARR(RQ),U))!($D(KILL)) K ENDD F S RP=$O(^RMPR(660,"AD",RO,RP)) Q:RP=""!($D(KILL)) D CK
Q
EXIT ;EXIT FROM REPORT HERE
I RMPRCOUN>0,$D(RMPREDT),'$D(KILL) W !!?32,"END OF REPORT"
I $E(IOST)["C"&($Y<22),'$D(ENDD) F W ! Q:$Y>20
I $D(RMPREDT),$E(IOST)["C",'$D(RMPRFLL),'$D(KILL),'$D(DUOUT),'$D(DTOUT),'$D(ENDD) K DIR S DIR(0)="E" D ^DIR
EXIT1 K RMPRARR,%DT,GOTO,QTYT,ITEM,KILL,ENDD,RQ,RP,RO,ITEM,RMPRI,COSTT,DIC,DIR,PAGE,RO,RMPRCOUN,RMPRSE,RMPRBDT,RMPREDT,RMPRX,RMPRY D ^%ZISC
Q
CK Q:'$D(^RMPR(660,RP,0))
I $P(^RMPR(660,RP,0),U,10)'=RMPR("STA") Q
I ($P(^(0),U,4)="X")!('$P(^(0),U,6))!($P(^(0),U,3)<RMPRBDT)!($P(^(0),U,3)>RMPREDT) Q I '$D(^PRC(441,$P(^RMPR(661,$P(^(0),U,6),0),U))) Q
I $P(RMPRARR(RQ),U)=$P(^RMPR(660,RP,0),U,6) 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)
W:$P(^RMPR(660,RP,0),U,9)'="" ?36,$E($P(^PRC(440,$P(^RMPR(660,RP,0),U,9),0),U,1),1,35)
W !,"SERIAL NBR:",?12,$E($P(^RMPR(660,RP,0),U,11),1,12),?25,"QTY: ",$J($P(^(0),U,7),4),?38,"TOTAL COST: ",$J($FN($P(^(0),U,16),"P",2),8) S QTYT=QTYT+$P(^(0),U,7),COSTT=COSTT+$P(^(0),U,16)
W ?60,$S($P(^RMPR(660,RP,0),U,4)="I":"INITIAL ISSUE",$P(^(0),U,4)="R":"REPLACEMENT",$P(^(0),U,4)="S":"SPARE",$P(^(0),U,4)="X":"REPAIR",$P(^(0),U,4)="5":"RENTAL",1:"UNK"),!,"INITIATOR: "
I $P(^RMPR(660,RP,0),U,27),$D(^VA(200,$P(^(0),U,27),0)) W ?15,$P(^(0),U),!
I $E(IOST)["C"&($Y>(IOSL-6)) S DIR(0)="E" D ^DIR S:Y<1 KILL=1 Q:Y<1 K DIR W @IOF D HEAD Q
I $Y>(IOSL-6) W @IOF D HEAD
Q
HEAD I $Y<2!(PAGE=1) W !,"ITEM HISTORY:",?15,$E($P(^PRC(441,$P(^RMPR(661,$P(^RMPR(660,RP,0),U,6),0),U,1),0),U,2),1,39),?63,"STA ",RMPR("STA"),?72,"PAGE ",PAGE S PAGE=PAGE+1
I W !!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"VENDOR" S Y=RMPRBDT D DD^%DT W ?55,Y,"-" S Y=RMPREDT D DD^%DT W Y
Q
REST D:'RMPRCOUN NONE Q:$D(KILL)!('RMPRCOUN) W !,"TOTAL DOLLARS SPENT ON THIS ITEM: ","$"_$J($FN(COSTT,"P",2),9),?45,"TOTAL QUANTITY ISSUED: ",$J(QTYT,4) I $O(RMPRARR(RQ)),$E(IOST)["C" W ! K DIR S DIR(0)="E" D ^DIR S:Y<1 KILL=1 W:'$D(KILL) @IOF
I $E(IOST)'["C",$O(RMPRARR(RQ)) W @IOF
S (COSTT,QTYT,RMPRCOUN)="" Q
NONE W @IOF,!!,"No Item History for this date range for:",!,$P(^PRC(441,$P(^RMPR(661,$P(RMPRARR(RQ),U),0),U),0),U,2) I $E(IOST)["C" K DIR S DIR(0)="E" W !!!! D ^DIR S:Y<1 KILL=1 S ENDD=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSE1 4022 printed Dec 13, 2024@02:37:40 Page 2
RMPRSE1 ;PHX/RFM-SEARCH FILE 660 ENTRIES FOR ITEM HISTORY ;8/29/1994
+1 ;;3.0;PROSTHETICS;**20,57,77,90**;Feb 09, 1996
+2 ;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION.
+3 ; - use RMPR("STA") instead of $$STA^RMPRUTIL.
+4 ;
EN NEW ITEM,RMPRARR,RMPRI
DO HOME^%ZIS
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT1
SET DIC="^RMPR(661,"
SET DIC(0)="AEQM"
FOR ITEM=1:1
SET DIC("A")="Select ITEM "_ITEM_": "
DO ^DIC
if $DATA(DTOUT)!(X["^")!(X=""&(ITEM=1))
GOTO EXIT1
if X=""
QUIT
Begin DoDot:1
+1 IF $DATA(RMPRI(+Y))
WRITE $CHAR(7)," ??",?40,"..Duplicate Item"
SET ITEM=ITEM-1
QUIT
+2 SET RMPRARR(ITEM)=+Y
SET RMPRI(+Y)=""
End DoDot:1
+3 SET RMPRCOUN=0
WRITE !!
SET %DT("A")="Beginning Date: "
SET %DT="AEPX"
SET %DT("B")="T-30"
DO ^%DT
SET RMPRBDT=Y
if Y<0
GOTO EXIT1
ENDATE SET %DT("A")="Ending Date: "
SET %DT="AEX"
SET %DT("B")="TODAY"
DO ^%DT
if Y<0
GOTO EXIT1
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 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT
+3 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+4 KILL IO("Q")
SET ZTDESC="SEARCH FOR RECALLED ITEM"
SET ZTRTN="PRINT^RMPRSE1"
SET ZTIO=ION
SET ZTSAVE("RMPRBDT")=""
SET ZTSAVE("RMPREDT")=""
SET ZTSAVE("RMPRI(")=""
SET ZTSAVE("RMPRX")=""
SET ZTSAVE("RMPRY")=""
SET ZTSAVE("RMPR(""STA"")")=""
SET ZTSAVE("RMPRARR(")=""
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT1
PRINT ;ENTRY POINT FOR PRINTING REPORT
+1 SET PAGE=1
SET (RMPRCOUN,RP,QTYT,COSTT)=0
IF IOST["C-"
DO WAIT^DICD
PRI SET RQ=0
FOR
SET RQ=$ORDER(RMPRARR(RQ))
if RQ=""!($DATA(KILL))
QUIT
SET RO=$PIECE(RMPRARR(RQ),U)
SET RO=RO-1
DO PRI1
+1 GOTO EXIT
PRI1 FOR
SET RO=$ORDER(^RMPR(660,"AD",RO))
if RO=""!(RO'=$PIECE(RMPRARR(RQ),U))
DO REST
if RO=""!(RO'=$PIECE(RMPRARR(RQ),U))!($DATA(KILL))
QUIT
KILL ENDD
FOR
SET RP=$ORDER(^RMPR(660,"AD",RO,RP))
if RP=""!($DATA(KILL))
QUIT
DO CK
+1 QUIT
EXIT ;EXIT FROM REPORT HERE
+1 IF RMPRCOUN>0
IF $DATA(RMPREDT)
IF '$DATA(KILL)
WRITE !!?32,"END OF REPORT"
+2 IF $EXTRACT(IOST)["C"&($Y<22)
IF '$DATA(ENDD)
FOR
WRITE !
if $Y>20
QUIT
+3 IF $DATA(RMPREDT)
IF $EXTRACT(IOST)["C"
IF '$DATA(RMPRFLL)
IF '$DATA(KILL)
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
IF '$DATA(ENDD)
KILL DIR
SET DIR(0)="E"
DO ^DIR
EXIT1 KILL RMPRARR,%DT,GOTO,QTYT,ITEM,KILL,ENDD,RQ,RP,RO,ITEM,RMPRI,COSTT,DIC,DIR,PAGE,RO,RMPRCOUN,RMPRSE,RMPRBDT,RMPREDT,RMPRX,RMPRY
DO ^%ZISC
+1 QUIT
CK if '$DATA(^RMPR(660,RP,0))
QUIT
+1 IF $PIECE(^RMPR(660,RP,0),U,10)'=RMPR("STA")
QUIT
+2 IF ($PIECE(^(0),U,4)="X")!('$PIECE(^(0),U,6))!($PIECE(^(0),U,3)<RMPRBDT)!($PIECE(^(0),U,3)>RMPREDT)
QUIT
IF '$DATA(^PRC(441,$PIECE(^RMPR(661,$PIECE(^(0),U,6),0),U)))
QUIT
+3 IF $PIECE(RMPRARR(RQ),U)=$PIECE(^RMPR(660,RP,0),U,6)
DO CON
+4 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)
+3 if $PIECE(^RMPR(660,RP,0),U,9)'=""
WRITE ?36,$EXTRACT($PIECE(^PRC(440,$PIECE(^RMPR(660,RP,0),U,9),0),U,1),1,35)
+4 WRITE !,"SERIAL NBR:",?12,$EXTRACT($PIECE(^RMPR(660,RP,0),U,11),1,12),?25,"QTY: ",$JUSTIFY($PIECE(^(0),U,7),4),?38,"TOTAL COST: ",$JUSTIFY($FNUMBER($PIECE(^(0),U,16),"P",2),8)
SET QTYT=QTYT+$PIECE(^(0),U,7)
SET COSTT=COSTT+$PIECE(^(0),U,16)
+5 WRITE ?60,$SELECT($PIECE(^RMPR(660,RP,0),U,4)="I":"INITIAL ISSUE",$PIECE(^(0),U,4)="R":"REPLACEMENT",$PIECE(^(0),U,4)="S":"SPARE",$PIECE(^(0),U,4)="X":"REPAIR",$PIECE(^(0),U,4)="5":"RENTAL",1:"UNK"),!,"INITIATOR: "
+6 IF $PIECE(^RMPR(660,RP,0),U,27)
IF $DATA(^VA(200,$PIECE(^(0),U,27),0))
WRITE ?15,$PIECE(^(0),U),!
+7 IF $EXTRACT(IOST)["C"&($Y>(IOSL-6))
SET DIR(0)="E"
DO ^DIR
if Y<1
SET KILL=1
if Y<1
QUIT
KILL DIR
WRITE @IOF
DO HEAD
QUIT
+8 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
+9 QUIT
HEAD IF $Y<2!(PAGE=1)
WRITE !,"ITEM HISTORY:",?15,$EXTRACT($PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^RMPR(660,RP,0),U,6),0),U,1),0),U,2),1,39),?63,"STA ",RMPR("STA"),?72,"PAGE ",PAGE
SET PAGE=PAGE+1
+1 IF $TEST
WRITE !!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"VENDOR"
SET Y=RMPRBDT
DO DD^%DT
WRITE ?55,Y,"-"
SET Y=RMPREDT
DO DD^%DT
WRITE Y
+2 QUIT
REST if 'RMPRCOUN
DO NONE
if $DATA(KILL)!('RMPRCOUN)
QUIT
WRITE !,"TOTAL DOLLARS SPENT ON THIS ITEM: ","$"_$JUSTIFY($FNUMBER(COSTT,"P",2),9),?45,"TOTAL QUANTITY ISSUED: ",$JUSTIFY(QTYT,4)
IF $ORDER(RMPRARR(RQ))
IF $EXTRACT(IOST)["C"
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
if Y<1
SET KILL=1
if '$DATA(KILL)
WRITE @IOF
+1 IF $EXTRACT(IOST)'["C"
IF $ORDER(RMPRARR(RQ))
WRITE @IOF
+2 SET (COSTT,QTYT,RMPRCOUN)=""
QUIT
NONE WRITE @IOF,!!,"No Item History for this date range for:",!,$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(RMPRARR(RQ),U),0),U),0),U,2)
IF $EXTRACT(IOST)["C"
KILL DIR
SET DIR(0)="E"
WRITE !!!!
DO ^DIR
if Y<1
SET KILL=1
SET ENDD=1
+1 QUIT
