- RMPRPI04 ;HIN/RVD-PROS STOCK ITEM RECORDS ;3/8/05 11:24
- ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
- ; DBIA #10090 - Read Access to entire file #4.
- ;
- D DIV4^RMPRSIT I $D(Y),(Y<0) Q
- S RS=RMPR("STA")
- ;
- EN K ^TMP($J),RMPRI,RMPRFLG S RMPREND=0 D HOME^%ZIS
- S DIC="^RMPR(661.1,",DIC(0)="AEQM"
- F HCPCS=1:1 S DIC("A")="Select HCPCS "_HCPCS_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(HCPCS=1)) EXIT1 Q:X="" D
- .Q:'$D(^RMPR(661.1,+Y,0)) S RMHCPC=$P(^RMPR(661.1,+Y,0),U,1)
- .I $D(RMPRI(RMHCPC)) W $C(7)," ??",?40,"..Duplicate HCPCS" S HCPCS=HCPCS-1 Q
- .S:RMHCPC'="" RMPRI(RMHCPC)=+Y
- S RMPRCOUN=0 W !! S %DT("A")="Beginning Date: ",%DT="AEPX"
- S %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="STOCK ITEM REPORT",ZTRTN="PRINT^RMPRPI04",ZTIO=ION
- S ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRI(")=""
- S ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(""STA"")")=""
- S ZTSAVE("RMPR(")=""
- D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
- ;
- ;Entry point for printing report.
- PRINT I $E(IOST)["C" W @IOF,!!,"Processing report......"
- I '$D(RMPRI) D NONEALL G EXIT
- ;call API
- ;input variables:
- ; RM = 'RM' subscript
- ; RS = station
- ; RMPRI = array of HCPCS
- ; RMPRBDT = beginning date
- ; RMPREDT = ending date
- ;
- S RS=RMPR("STA"),RM="RM"
- S RMCHK=$$THIS^RMPRPI03(RM,RS,RMPRBDT,RMPREDT,.RMPRI)
- I RMCHK W !!,"ERROR NUMBER = ",RMCHK,!,"*** Error in API RMPRPI03 !!!" G EXIT
- ;
- S RMBDATE=$E(RMPRBDT,4,5)_"/"_$E(RMPRBDT,6,7)_"/"_$E(RMPRBDT,2,3)
- S RMPAGE=1
- S (RMPREND,RP,QTYT,RMIFL,RMCO,RMTOCO,RMTOCOH,RMSTAFL,RMSUF,RMQTYT)=0
- D HEAD
- S RQ="" F S RQ=$O(RMPRI(RQ)) Q:RQ="" I '$D(^TMP($J,"RM",RQ)) D NONE
- D WRI
- W !,"<End of Report>"
- ;
- EXIT ;exit here if report prints in home device.
- I $E(IOST)["C",'$D(DUOUT),'$G(RMPREND) K DIR S DIR(0)="E" D ^DIR
- ;
- EXIT1 ;close device and clean-up variables.
- D ^%ZISC
- N RMPR,RMPRSITE D KILL^XUSCLEAN
- K ^TMP($J)
- Q
- ;end of processing (exit program)
- ;
- ; RH = HCPCS
- ; RI = HCPCS ITEM NAME
- ; R2 = ITEM NUMBER
- ; R3 =SEQUENCE
- ;
- WRI S (RMFH,RMFI,RMPRFLG,RMTOCO,RMTOCOH,RMTOCOI)=0
- S (RMITEM,RH)=""
- F S RH=$O(^TMP($J,"RM",RH)) D:RMFH HTOTAL D:RH'="" HEAD1 Q:RH="" S (RIT2,RI)="" F S RI=$O(^TMP($J,"RM",RH,RI)) Q:RI="" D
- .F R2=0:0 S R2=$O(^TMP($J,"RM",RH,RI,R2)) D:RMFI ITOTAL Q:(R2'>0)!(RMPREND) D:RIT2'=R2 IHEAD F R3=0:0 S R3=$O(^TMP($J,"RM",RH,RI,R2,R3)) Q:(R3'>0)!(RMPREND) D
- ..S RDATA=^TMP($J,"RM",RH,RI,R2,R3)
- ..S RMDAT=$P(RDATA,U,1),RMTIM=$P(RDATA,U,2),RMOPE=$P(RDATA,U,3)
- ..S RMCLO=$P(RDATA,U,4),RMQTY=$P(RDATA,U,5)
- ..S RMVAL=$P(RDATA,U,6),RMTRA=$P(RDATA,U,7),RMPAT=$P(RDATA,U,8)
- ..S RMSSN=$P(RDATA,U,9),RMUSE=$E($P(RDATA,U,10),1,10)
- ..S RMITE=$P(RDATA,U,11)
- ..S RMAVCO=$P(RDATA,U,11) S:RMAVCO'="" RMCO=RMAVCO*RMQTY
- ..S RIT2=R2
- ..I 'RMPRFLG D HEAD1
- ..S (RMFH,RMFI)=1
- ..W !,RMDAT
- ..I RMPAT'="" D
- ...W ?9,$E(RMPAT,1,14),?26,$P(RMSSN,"-",3),?31,RMUSE,?45,$J(RMQTY,4)
- ...W ?69,$J(RMVAL,9,2)
- ..I RMTRA="PATIENT ISSUE" S RMTOCO=RMTOCO+RMVAL
- ..I RMTRA="RETURN IN" S RMTOCO=RMTOCO-RMVAL
- ..I RMPAT="" D
- ...W:RMTRA="RECEIPT" ?9,"**Note: ",RMTRA,?31,RMUSE,?60,$J(RMQTY,4),?69,$J(RMVAL,9,2)
- ...W:RMTRA="ORDER" ?9,"**Note: ",RMTRA,?31,RMUSE,?54,$J(RMQTY,4),?69,$J(RMVAL,9,2)
- ...I (RMTRA'="RECEIPT"),(RMTRA'="ORDER") W ?9,"**Note: ",RMTRA,?31,RMUSE,?45,$J(RMQTY,4),?69,$J(RMVAL,9,2)
- ..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 S RMPRFLG=1
- Q
- ;
- HEAD ;print headers
- W !,"*** ISSUE and STOCK CONTROL RECORD - PROSTHETICS STOCK ITEMS ***"
- W ?65,"Page: ",RMPAGE,!,?30,"station: "
- W $E($P($G(^DIC(4,RMPR("STA"),0)),U,1),1,20)
- N X,% S Y=RMPRBDT D DD^%DT W !,Y," to " S Y=RMPREDT D DD^%DT W Y
- S RMPAGE=RMPAGE+1
- Q
- ;
- IHEAD S RMDAHC=$O(^RMPR(661.1,"B",RH,0))
- S RMITEM=$E(RMITEM,1,26)
- W !,"HCPCS: ",RH,"-",R2,?16,"Item: ",RI
- S RMI=1
- Q
- ;
- HEAD1 ;write column headers
- 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
- W !,RMPR("L")
- W !,?45,"QTY",?54,"QTY",?61,"QTY",?72,"DOLLAR"
- W !," DATE",?9,"PATIENT",?26,"SSN",?31,"USER",?44,"ISSUE"
- W ?53,"ORDER",?61,"REC",?72,"VALUE"
- W !," ----",?9,"-------",?26,"---",?31,"----",?44,"-----"
- W ?53,"-----",?61,"---",?72,"------"
- S RMPRFLG=1
- Q
- ;
- HTOTAL ;
- I RMFH,'RMPREND D
- .W !!,?23,"*** Dollar Value of HCPCS Issued",?60,"="
- .W ?60,$J(RMTOCOH,10,2)
- S (RMTOCOH,RMFH)=0
- Q
- ;
- ITOTAL ;prints totals.
- I RMFI,'RMPREND D
- .W !,?42,"--------------------------------------",!
- .W ?23,"*** Dollar Value of Item Issued",?60,"=",?60,$J(RMTOCO,10,2)
- S RMTOCOH=RMTOCOH+RMTOCO,(RMTOCO,RMCO,RMFI)=0
- Q
- ;
- NONE ;nothing to report.
- W !,RMPR("L"),!,"No Item Statistics for HCPCS: "
- W RQ,"...for this date range !!!"
- Q
- ;
- NONEALL W !!,"NO DATA AT THIS DATE RANGE!!!!"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPI04 5246 printed Feb 19, 2025@00:02:26 Page 2
- RMPRPI04 ;HIN/RVD-PROS STOCK ITEM RECORDS ;3/8/05 11:24
- +1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
- +2 ; DBIA #10090 - Read Access to entire file #4.
- +3 ;
- +4 DO DIV4^RMPRSIT
- IF $DATA(Y)
- IF (Y<0)
- QUIT
- +5 SET RS=RMPR("STA")
- +6 ;
- EN KILL ^TMP($JOB),RMPRI,RMPRFLG
- SET RMPREND=0
- DO HOME^%ZIS
- +1 SET DIC="^RMPR(661.1,"
- SET DIC(0)="AEQM"
- +2 FOR HCPCS=1:1
- SET DIC("A")="Select HCPCS "_HCPCS_": "
- DO ^DIC
- if $DATA(DTOUT)!(X["^")!(X=""&(HCPCS=1))
- GOTO EXIT1
- if X=""
- QUIT
- Begin DoDot:1
- +3 if '$DATA(^RMPR(661.1,+Y,0))
- QUIT
- SET RMHCPC=$PIECE(^RMPR(661.1,+Y,0),U,1)
- +4 IF $DATA(RMPRI(RMHCPC))
- WRITE $CHAR(7)," ??",?40,"..Duplicate HCPCS"
- SET HCPCS=HCPCS-1
- QUIT
- +5 if RMHCPC'=""
- SET RMPRI(RMHCPC)=+Y
- End DoDot:1
- +6 SET RMPRCOUN=0
- WRITE !!
- SET %DT("A")="Beginning Date: "
- SET %DT="AEPX"
- +7 SET %DT("B")="T-30"
- DO ^%DT
- SET RMPRBDT=Y
- if Y<0
- GOTO EXIT1
- +8 ;
- ENDATE SET %DT("A")="Ending Date: "
- SET %DT="AEX"
- SET %DT("B")="TODAY"
- DO ^%DT
- +1 if Y<0
- GOTO EXIT1
- +2 IF RMPRBDT>Y
- WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
- GOTO ENDATE
- +3 if Y<0
- GOTO EXIT
- SET RMPREDT=Y
- SET Y=RMPRBDT
- DO DD^%DT
- SET RMPRX=Y
- SET Y=RMPREDT
- +4 DO DD^%DT
- SET RMPRY=Y
- +5 SET %ZIS="MQ"
- KILL IOP
- DO ^%ZIS
- if POP
- GOTO EXIT
- +6 IF '$DATA(IO("Q"))
- USE IO
- GOTO PRINT
- +7 KILL IO("Q")
- SET ZTDESC="STOCK ITEM REPORT"
- SET ZTRTN="PRINT^RMPRPI04"
- SET ZTIO=ION
- +8 SET ZTSAVE("RMPRBDT")=""
- SET ZTSAVE("RMPREDT")=""
- SET ZTSAVE("RMPRI(")=""
- +9 SET ZTSAVE("RMPRX")=""
- SET ZTSAVE("RMPRY")=""
- SET ZTSAVE("RMPR(""STA"")")=""
- +10 SET ZTSAVE("RMPR(")=""
- +11 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"REQUEST QUEUED!"
- HANG 1
- GOTO EXIT1
- +12 ;
- +13 ;Entry point for printing report.
- PRINT IF $EXTRACT(IOST)["C"
- WRITE @IOF,!!,"Processing report......"
- +1 IF '$DATA(RMPRI)
- DO NONEALL
- GOTO EXIT
- +2 ;call API
- +3 ;input variables:
- +4 ; RM = 'RM' subscript
- +5 ; RS = station
- +6 ; RMPRI = array of HCPCS
- +7 ; RMPRBDT = beginning date
- +8 ; RMPREDT = ending date
- +9 ;
- +10 SET RS=RMPR("STA")
- SET RM="RM"
- +11 SET RMCHK=$$THIS^RMPRPI03(RM,RS,RMPRBDT,RMPREDT,.RMPRI)
- +12 IF RMCHK
- WRITE !!,"ERROR NUMBER = ",RMCHK,!,"*** Error in API RMPRPI03 !!!"
- GOTO EXIT
- +13 ;
- +14 SET RMBDATE=$EXTRACT(RMPRBDT,4,5)_"/"_$EXTRACT(RMPRBDT,6,7)_"/"_$EXTRACT(RMPRBDT,2,3)
- +15 SET RMPAGE=1
- +16 SET (RMPREND,RP,QTYT,RMIFL,RMCO,RMTOCO,RMTOCOH,RMSTAFL,RMSUF,RMQTYT)=0
- +17 DO HEAD
- +18 SET RQ=""
- FOR
- SET RQ=$ORDER(RMPRI(RQ))
- if RQ=""
- QUIT
- IF '$DATA(^TMP($JOB,"RM",RQ))
- DO NONE
- +19 DO WRI
- +20 WRITE !,"<End of Report>"
- +21 ;
- EXIT ;exit here if report prints in home device.
- +1 IF $EXTRACT(IOST)["C"
- IF '$DATA(DUOUT)
- IF '$GET(RMPREND)
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- +2 ;
- EXIT1 ;close device and clean-up variables.
- +1 DO ^%ZISC
- +2 NEW RMPR,RMPRSITE
- DO KILL^XUSCLEAN
- +3 KILL ^TMP($JOB)
- +4 QUIT
- +5 ;end of processing (exit program)
- +6 ;
- +7 ; RH = HCPCS
- +8 ; RI = HCPCS ITEM NAME
- +9 ; R2 = ITEM NUMBER
- +10 ; R3 =SEQUENCE
- +11 ;
- WRI SET (RMFH,RMFI,RMPRFLG,RMTOCO,RMTOCOH,RMTOCOI)=0
- +1 SET (RMITEM,RH)=""
- +2 FOR
- SET RH=$ORDER(^TMP($JOB,"RM",RH))
- if RMFH
- DO HTOTAL
- if RH'=""
- DO HEAD1
- if RH=""
- QUIT
- SET (RIT2,RI)=""
- FOR
- SET RI=$ORDER(^TMP($JOB,"RM",RH,RI))
- if RI=""
- QUIT
- Begin DoDot:1
- +3 FOR R2=0:0
- SET R2=$ORDER(^TMP($JOB,"RM",RH,RI,R2))
- if RMFI
- DO ITOTAL
- if (R2'>0)!(RMPREND)
- QUIT
- if RIT2'=R2
- DO IHEAD
- FOR R3=0:0
- SET R3=$ORDER(^TMP($JOB,"RM",RH,RI,R2,R3))
- if (R3'>0)!(RMPREND)
- QUIT
- Begin DoDot:2
- +4 SET RDATA=^TMP($JOB,"RM",RH,RI,R2,R3)
- +5 SET RMDAT=$PIECE(RDATA,U,1)
- SET RMTIM=$PIECE(RDATA,U,2)
- SET RMOPE=$PIECE(RDATA,U,3)
- +6 SET RMCLO=$PIECE(RDATA,U,4)
- SET RMQTY=$PIECE(RDATA,U,5)
- +7 SET RMVAL=$PIECE(RDATA,U,6)
- SET RMTRA=$PIECE(RDATA,U,7)
- SET RMPAT=$PIECE(RDATA,U,8)
- +8 SET RMSSN=$PIECE(RDATA,U,9)
- SET RMUSE=$EXTRACT($PIECE(RDATA,U,10),1,10)
- +9 SET RMITE=$PIECE(RDATA,U,11)
- +10 SET RMAVCO=$PIECE(RDATA,U,11)
- if RMAVCO'=""
- SET RMCO=RMAVCO*RMQTY
- +11 SET RIT2=R2
- +12 IF 'RMPRFLG
- DO HEAD1
- +13 SET (RMFH,RMFI)=1
- +14 WRITE !,RMDAT
- +15 IF RMPAT'=""
- Begin DoDot:3
- +16 WRITE ?9,$EXTRACT(RMPAT,1,14),?26,$PIECE(RMSSN,"-",3),?31,RMUSE,?45,$JUSTIFY(RMQTY,4)
- +17 WRITE ?69,$JUSTIFY(RMVAL,9,2)
- End DoDot:3
- +18 IF RMTRA="PATIENT ISSUE"
- SET RMTOCO=RMTOCO+RMVAL
- +19 IF RMTRA="RETURN IN"
- SET RMTOCO=RMTOCO-RMVAL
- +20 IF RMPAT=""
- Begin DoDot:3
- +21 if RMTRA="RECEIPT"
- WRITE ?9,"**Note: ",RMTRA,?31,RMUSE,?60,$JUSTIFY(RMQTY,4),?69,$JUSTIFY(RMVAL,9,2)
- +22 if RMTRA="ORDER"
- WRITE ?9,"**Note: ",RMTRA,?31,RMUSE,?54,$JUSTIFY(RMQTY,4),?69,$JUSTIFY(RMVAL,9,2)
- +23 IF (RMTRA'="RECEIPT")
- IF (RMTRA'="ORDER")
- WRITE ?9,"**Note: ",RMTRA,?31,RMUSE,?45,$JUSTIFY(RMQTY,4),?69,$JUSTIFY(RMVAL,9,2)
- End DoDot:3
- +24 SET RMPRFLG=1
- +25 IF $EXTRACT(IOST)["C"&($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
- +26 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HEAD
- DO HEAD1
- SET RMPRFLG=1
- End DoDot:2
- End DoDot:1
- +27 QUIT
- +28 ;
- HEAD ;print headers
- +1 WRITE !,"*** ISSUE and STOCK CONTROL RECORD - PROSTHETICS STOCK ITEMS ***"
- +2 WRITE ?65,"Page: ",RMPAGE,!,?30,"station: "
- +3 WRITE $EXTRACT($PIECE($GET(^DIC(4,RMPR("STA"),0)),U,1),1,20)
- +4 NEW X,%
- SET Y=RMPRBDT
- DO DD^%DT
- WRITE !,Y," to "
- SET Y=RMPREDT
- DO DD^%DT
- WRITE Y
- +5 SET RMPAGE=RMPAGE+1
- +6 QUIT
- +7 ;
- IHEAD SET RMDAHC=$ORDER(^RMPR(661.1,"B",RH,0))
- +1 SET RMITEM=$EXTRACT(RMITEM,1,26)
- +2 WRITE !,"HCPCS: ",RH,"-",R2,?16,"Item: ",RI
- +3 SET RMI=1
- +4 QUIT
- +5 ;
- HEAD1 ;write column headers
- +1 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DTOUT)!(Y=0)
- SET RMPREND=1
- if RMPREND
- QUIT
- WRITE @IOF
- DO HEAD
- +2 WRITE !,RMPR("L")
- +3 WRITE !,?45,"QTY",?54,"QTY",?61,"QTY",?72,"DOLLAR"
- +4 WRITE !," DATE",?9,"PATIENT",?26,"SSN",?31,"USER",?44,"ISSUE"
- +5 WRITE ?53,"ORDER",?61,"REC",?72,"VALUE"
- +6 WRITE !," ----",?9,"-------",?26,"---",?31,"----",?44,"-----"
- +7 WRITE ?53,"-----",?61,"---",?72,"------"
- +8 SET RMPRFLG=1
- +9 QUIT
- +10 ;
- HTOTAL ;
- +1 IF RMFH
- IF 'RMPREND
- Begin DoDot:1
- +2 WRITE !!,?23,"*** Dollar Value of HCPCS Issued",?60,"="
- +3 WRITE ?60,$JUSTIFY(RMTOCOH,10,2)
- End DoDot:1
- +4 SET (RMTOCOH,RMFH)=0
- +5 QUIT
- +6 ;
- ITOTAL ;prints totals.
- +1 IF RMFI
- IF 'RMPREND
- Begin DoDot:1
- +2 WRITE !,?42,"--------------------------------------",!
- +3 WRITE ?23,"*** Dollar Value of Item Issued",?60,"=",?60,$JUSTIFY(RMTOCO,10,2)
- End DoDot:1
- +4 SET RMTOCOH=RMTOCOH+RMTOCO
- SET (RMTOCO,RMCO,RMFI)=0
- +5 QUIT
- +6 ;
- NONE ;nothing to report.
- +1 WRITE !,RMPR("L"),!,"No Item Statistics for HCPCS: "
- +2 WRITE RQ,"...for this date range !!!"
- +3 QUIT
- +4 ;
- NONEALL WRITE !!,"NO DATA AT THIS DATE RANGE!!!!"
- +1 QUIT
