RMPRPI10 ;HIN/RVD-PRINT ITEM DETAIL OVER 30 DAYS ;3/8/05 11:40
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
; DBIA #10090 - Read Access to entire file #4.
; DBIA #10096 - Access to all %ZOSF nodes.
;
K DIC,DIR,%DT
D DIV4^RMPRSIT I $D(Y),(Y<0) Q
S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
;
EN K RMPRI,RMPRFLG S RMPREND=0 D HOME^%ZIS
S DIC="^RMPR(661.5,",DIC(0)="AEQ"
S DIC("S")="I $P(^RMPR(661.5,+Y,0),U,2)=RMPR(""STA"")"
;
EN1 R !!,"Enter 'ALL' for all Locations or 'RETURN' to select individual Locations: ",RMENTER:DTIME G:$D(DTOUT)!$D(DUOUT)!(RMENTER="^") EXIT1
G:RMENTER["?" EN1
S X=RMENTER X ^%ZOSF("UPPERCASE") S RMENTER=Y
I RMENTER="ALL" S RMPRI="*" G CONT
W ! F RML=1:1 S DIC("A")="Select Location "_RML_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(RML=1)) EXIT1 Q:X="" D
.S RMLOCI=+Y
.I $D(RMPRI(RMLOCI)) W $C(7)," ??",?40,"..Duplicate Location" S RML=RML-1 Q
.S RMPRI(RMLOCI)=""
;
CONT ;
K DIR
S DIR("B")="NEW Items",DIR("A")="Enter a SOURCE Creteria"
S DIR(0)="S^V:OLD Items;C:NEW Items"
D ^DIR G:$D(DUOUT)!$D(DIRUT)!$D(DTOUT) EXIT1
S RE=Y K DIR
;
DT ;
W ! S %DT("A")="Beginning Date: ",%DT="AEPX",%DT("B")="T-30" D ^%DT S RMB=Y G:Y<0 EXIT1
ENDATE S %DT("A")="Ending Date: ",%DT="AEX",%DT("B")="TODAY" D ^%DT G:Y<0 EXIT1 I RMB>Y W !,$C(7),"Invalid Date Range Selection!!" G ENDATE
S RME=Y
;
G:'$D(RMPRI) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1
I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="PROSTHETIC INVENTORY LOCATION SUMMARY"
S ZTRTN="PRINT^RMPRPI10",ZTIO=ION,ZTSAVE("RMPRI(")=""
S ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMDAT")="",ZTSAVE("RMPR(")=""
S ZTSAVE("RE")="",ZTSAVE("RMPRI")=""
S ZTSAVE("RME")="",ZTSAVE("RMB")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
;
PRINT I $E(IOST)["C" W !!,"Processing report....."
;
;call API
;input variables:
; RM = any subscript to be used
; RS = rmpr("sta")
; RE = source (V or C)
; RMPRI = rmpri(location array; '*' for all location )
; RMB = beginning date
; RME = ending date
;
S X1=RME,X2=RMB
D ^%DTC S RMCALDAY=X+1
S Y=RMB D DD^%DT S RMBDAT=Y S Y=RME D DD^%DT S RMEDAT=Y
D NOW^%DTC S Y=% X ^DD("DD") S RMDAT=Y
S RSOU=$S(RE="V":"USED",RE="C":"NEW",1:"")
S RS=RMPR("STA"),RM="RM"
;
S RMCHK=$$LOC^RMPRPI07(RM,RS,.RMPRI,RE,RMB,RME)
I RMCHK W !!,"ERROR NUMBER = ",RMCHK,!,"***Error in API RMPRPI07 !!!!",!! G EXIT
;
S RMPAGE=1,RMPREND=0
I '$D(^TMP($J,"RM")) D NONE G EXIT
W:$E(IOST)["C" @IOF
D HEAD,WRI
G EXIT
;
;write/print report
;rl = Location
;rh = HCPCS
;j = Item
;k = Item description
;
;
WRI S RL=""
F S RL=$O(^TMP($J,"RM",RL)) Q:(RL="")!(RMPREND) K RMPRFLG S RH="" F S RH=$O(^TMP($J,"RM",RL,RH)) Q:(RH="")!(RMPREND) S J="" D
.F S J=$O(^TMP($J,"RM",RL,RH,J)) Q:(J="")!(RMPREND) S K="" F S K=$O(^TMP($J,"RM",RL,RH,J,K)) Q:(K="")!(RMPREND) D
..S RM3=^TMP($J,"RM",RL,RH,J,K)
..S RMIT=K
..S RMQTY=$P(RM3,U,1)
..S RMCOS=$P(RM3,U,2)
..S RMDAU=RMQTY/RMCALDAY
..S RMDOH=""
..S RMSOH=$P(RM3,U,5)
..S:+RMDAU RMDOH=$J(RMSOH/RMDAU,0,1) S:RMDOH>999 RMDOH=">999"
..I 'RMDAU S RMDOH=">"_RMCALDAY
..S RMDAU=$J(RMDAU,0,3)
..S RMTDV=$P(RM3,U,6)
..I '$D(RMPRFLG) D HEAD1
..S RMIDE=$E(J,1,13)
..W !,RH_"-"_RMIT,?10,RMIDE,?24,$J(RMQTY,4),?29,$J($FN(RMCOS,",",2),9),?42,RMDAU,?54,$J(RMDOH,4)
..W ?61,$J(RMSOH,5),?70,$J($FN(RMTDV,",",2),10)
..S RMPRFLG=1
..I $E(IOST)["C",($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD,HEAD1 Q
..I $Y>(IOSL-6) W @IOF D HEAD,HEAD1 Q
W !,RMPR("L"),!,"<End of Report>"
Q
;
HEAD W !,"*** STOCK ON HAND OVER DATE RANGE ***"," for ",RSOU," Items"
W !,"Station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,20),?30,"Run Date: ",RMDAT
W ?68,"PAGE: ",RMPAGE
W !,RMBDAT," to ",RMEDAT,?30,"[ ",RMCALDAY," calendar days ]"
S RMPAGE=RMPAGE+1
Q
;
HEAD1 I $E(IOST)["C",($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD
I $E(IOST)'["C",($Y>(IOSL-6)) W @IOF D HEAD
W !,RMPR("L")
W !,"Location: ",$P($G(^RMPR(661.5,RL,0)),"^",1)
W !,?25,"QTY",?35,"$",?41,"DAYS AVE"
W ?54,"DAYS",?62,"STOCK",?72,"TOTAL $"
W !,"HCPCS",?10,"ITEM",?24,"ISSUE",?33,"VALUE"
W ?40,"USAGE RATE",?52,"ON-HAND",?61,"ON-HAND",?70,"VAL ON-HND"
W !,"-----",?10,"----",?24,"-----",?33,"-----"
W ?40,"----------",?52,"-------",?61,"-------",?70,"----------"
S RMPRFLG=1
Q
;
EXIT I $E(IOST)["C",'RMPREND W ! S DIR(0)="E" D ^DIR
;
EXIT1 D ^%ZISC
N RMPR,RMPRSITE D KILL^XUSCLEAN
K ^TMP($J)
Q
;
NONE ;
W:$E(IOST)["C" @IOF
D HEAD
W !,RMPR("L")
W !!,"NO DATA to print !!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPI10 4643 printed Nov 22, 2024@17:46:03 Page 2
RMPRPI10 ;HIN/RVD-PRINT ITEM DETAIL OVER 30 DAYS ;3/8/05 11:40
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ; DBIA #10090 - Read Access to entire file #4.
+3 ; DBIA #10096 - Access to all %ZOSF nodes.
+4 ;
+5 KILL DIC,DIR,%DT
+6 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
QUIT
+7 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+8 ;
EN KILL RMPRI,RMPRFLG
SET RMPREND=0
DO HOME^%ZIS
+1 SET DIC="^RMPR(661.5,"
SET DIC(0)="AEQ"
+2 SET DIC("S")="I $P(^RMPR(661.5,+Y,0),U,2)=RMPR(""STA"")"
+3 ;
EN1 READ !!,"Enter 'ALL' for all Locations or 'RETURN' to select individual Locations: ",RMENTER:DTIME
if $DATA(DTOUT)!$DATA(DUOUT)!(RMENTER="^")
GOTO EXIT1
+1 if RMENTER["?"
GOTO EN1
+2 SET X=RMENTER
XECUTE ^%ZOSF("UPPERCASE")
SET RMENTER=Y
+3 IF RMENTER="ALL"
SET RMPRI="*"
GOTO CONT
+4 WRITE !
FOR RML=1:1
SET DIC("A")="Select Location "_RML_": "
DO ^DIC
if $DATA(DTOUT)!(X["^")!(X=""&(RML=1))
GOTO EXIT1
if X=""
QUIT
Begin DoDot:1
+5 SET RMLOCI=+Y
+6 IF $DATA(RMPRI(RMLOCI))
WRITE $CHAR(7)," ??",?40,"..Duplicate Location"
SET RML=RML-1
QUIT
+7 SET RMPRI(RMLOCI)=""
End DoDot:1
+8 ;
CONT ;
+1 KILL DIR
+2 SET DIR("B")="NEW Items"
SET DIR("A")="Enter a SOURCE Creteria"
+3 SET DIR(0)="S^V:OLD Items;C:NEW Items"
+4 DO ^DIR
if $DATA(DUOUT)!$DATA(DIRUT)!$DATA(DTOUT)
GOTO EXIT1
+5 SET RE=Y
KILL DIR
+6 ;
DT ;
+1 WRITE !
SET %DT("A")="Beginning Date: "
SET %DT="AEPX"
SET %DT("B")="T-30"
DO ^%DT
SET RMB=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 RMB>Y
WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
GOTO ENDATE
+1 SET RME=Y
+2 ;
+3 if '$DATA(RMPRI)
GOTO EXIT1
SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT1
+4 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+5 KILL IO("Q")
SET ZTDESC="PROSTHETIC INVENTORY LOCATION SUMMARY"
+6 SET ZTRTN="PRINT^RMPRPI10"
SET ZTIO=ION
SET ZTSAVE("RMPRI(")=""
+7 SET ZTSAVE("RMPR(""STA"")")=""
SET ZTSAVE("RMDAT")=""
SET ZTSAVE("RMPR(")=""
+8 SET ZTSAVE("RE")=""
SET ZTSAVE("RMPRI")=""
+9 SET ZTSAVE("RME")=""
SET ZTSAVE("RMB")=""
+10 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT1
+11 ;
PRINT IF $EXTRACT(IOST)["C"
WRITE !!,"Processing report....."
+1 ;
+2 ;call API
+3 ;input variables:
+4 ; RM = any subscript to be used
+5 ; RS = rmpr("sta")
+6 ; RE = source (V or C)
+7 ; RMPRI = rmpri(location array; '*' for all location )
+8 ; RMB = beginning date
+9 ; RME = ending date
+10 ;
+11 SET X1=RME
SET X2=RMB
+12 DO ^%DTC
SET RMCALDAY=X+1
+13 SET Y=RMB
DO DD^%DT
SET RMBDAT=Y
SET Y=RME
DO DD^%DT
SET RMEDAT=Y
+14 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET RMDAT=Y
+15 SET RSOU=$SELECT(RE="V":"USED",RE="C":"NEW",1:"")
+16 SET RS=RMPR("STA")
SET RM="RM"
+17 ;
+18 SET RMCHK=$$LOC^RMPRPI07(RM,RS,.RMPRI,RE,RMB,RME)
+19 IF RMCHK
WRITE !!,"ERROR NUMBER = ",RMCHK,!,"***Error in API RMPRPI07 !!!!",!!
GOTO EXIT
+20 ;
+21 SET RMPAGE=1
SET RMPREND=0
+22 IF '$DATA(^TMP($JOB,"RM"))
DO NONE
GOTO EXIT
+23 if $EXTRACT(IOST)["C"
WRITE @IOF
+24 DO HEAD
DO WRI
+25 GOTO EXIT
+26 ;
+27 ;write/print report
+28 ;rl = Location
+29 ;rh = HCPCS
+30 ;j = Item
+31 ;k = Item description
+32 ;
+33 ;
WRI SET RL=""
+1 FOR
SET RL=$ORDER(^TMP($JOB,"RM",RL))
if (RL="")!(RMPREND)
QUIT
KILL RMPRFLG
SET RH=""
FOR
SET RH=$ORDER(^TMP($JOB,"RM",RL,RH))
if (RH="")!(RMPREND)
QUIT
SET J=""
Begin DoDot:1
+2 FOR
SET J=$ORDER(^TMP($JOB,"RM",RL,RH,J))
if (J="")!(RMPREND)
QUIT
SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"RM",RL,RH,J,K))
if (K="")!(RMPREND)
QUIT
Begin DoDot:2
+3 SET RM3=^TMP($JOB,"RM",RL,RH,J,K)
+4 SET RMIT=K
+5 SET RMQTY=$PIECE(RM3,U,1)
+6 SET RMCOS=$PIECE(RM3,U,2)
+7 SET RMDAU=RMQTY/RMCALDAY
+8 SET RMDOH=""
+9 SET RMSOH=$PIECE(RM3,U,5)
+10 if +RMDAU
SET RMDOH=$JUSTIFY(RMSOH/RMDAU,0,1)
if RMDOH>999
SET RMDOH=">999"
+11 IF 'RMDAU
SET RMDOH=">"_RMCALDAY
+12 SET RMDAU=$JUSTIFY(RMDAU,0,3)
+13 SET RMTDV=$PIECE(RM3,U,6)
+14 IF '$DATA(RMPRFLG)
DO HEAD1
+15 SET RMIDE=$EXTRACT(J,1,13)
+16 WRITE !,RH_"-"_RMIT,?10,RMIDE,?24,$JUSTIFY(RMQTY,4),?29,$JUSTIFY($FNUMBER(RMCOS,",",2),9),?42,RMDAU,?54,$JUSTIFY(RMDOH,4)
+17 WRITE ?61,$JUSTIFY(RMSOH,5),?70,$JUSTIFY($FNUMBER(RMTDV,",",2),10)
+18 SET RMPRFLG=1
+19 IF $EXTRACT(IOST)["C"
IF ($Y>(IOSL-7))
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!(Y=0)
SET RMPREND=1
if RMPREND
QUIT
WRITE @IOF
DO HEAD
DO HEAD1
QUIT
+20 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
QUIT
End DoDot:2
End DoDot:1
+21 WRITE !,RMPR("L"),!,"<End of Report>"
+22 QUIT
+23 ;
HEAD WRITE !,"*** STOCK ON HAND OVER DATE RANGE ***"," for ",RSOU," Items"
+1 WRITE !,"Station: ",$EXTRACT($PIECE($GET(^DIC(4,RS,0)),U,1),1,20),?30,"Run Date: ",RMDAT
+2 WRITE ?68,"PAGE: ",RMPAGE
+3 WRITE !,RMBDAT," to ",RMEDAT,?30,"[ ",RMCALDAY," calendar days ]"
+4 SET RMPAGE=RMPAGE+1
+5 QUIT
+6 ;
HEAD1 IF $EXTRACT(IOST)["C"
IF ($Y>(IOSL-7))
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!(Y=0)
SET RMPREND=1
if RMPREND
QUIT
WRITE @IOF
DO HEAD
+1 IF $EXTRACT(IOST)'["C"
IF ($Y>(IOSL-6))
WRITE @IOF
DO HEAD
+2 WRITE !,RMPR("L")
+3 WRITE !,"Location: ",$PIECE($GET(^RMPR(661.5,RL,0)),"^",1)
+4 WRITE !,?25,"QTY",?35,"$",?41,"DAYS AVE"
+5 WRITE ?54,"DAYS",?62,"STOCK",?72,"TOTAL $"
+6 WRITE !,"HCPCS",?10,"ITEM",?24,"ISSUE",?33,"VALUE"
+7 WRITE ?40,"USAGE RATE",?52,"ON-HAND",?61,"ON-HAND",?70,"VAL ON-HND"
+8 WRITE !,"-----",?10,"----",?24,"-----",?33,"-----"
+9 WRITE ?40,"----------",?52,"-------",?61,"-------",?70,"----------"
+10 SET RMPRFLG=1
+11 QUIT
+12 ;
EXIT IF $EXTRACT(IOST)["C"
IF 'RMPREND
WRITE !
SET DIR(0)="E"
DO ^DIR
+1 ;
EXIT1 DO ^%ZISC
+1 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+2 KILL ^TMP($JOB)
+3 QUIT
+4 ;
NONE ;
+1 if $EXTRACT(IOST)["C"
WRITE @IOF
+2 DO HEAD
+3 WRITE !,RMPR("L")
+4 WRITE !!,"NO DATA to print !!!"
+5 QUIT
