- 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 Jan 18, 2025@03:37:13 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