- 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 Jan 18, 2025@03:38:49 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