RMPR293 ;PHX/JLT/HNB -DISPLAY JOB RECORD INFO ;[ 10/04/94 10:15 AM ]
;;3.0;PROSTHETICS;**50**;Feb 09, 1996
;
; ODJ - patch 50 - 7/14/00 - fix display problem which is causing
; remarks not to be displayed
; NOIS CTX-0197-70330
; - patch 50 - 7/18/00 - prevent crash at DISP+8 see NOIS's
; FGH-1099-30059, KAN-0500-40811
;
DISP(PRDA) ;CALLED FROM TEMPLATE [RMPR 25293] AND RMPRPRT
; VARIABLES REQUIRED: RMPRDA - ENTRY IN FILE 664.1
; PRDA - ENTRY IN FILE 664.1 (COPY PASSED IN)
; RMPR("L") - A LINE OF '-'S
Q:$G(PRDA)'>1
;disp is called from RMPR29R, and print template [RMPR 25293]
;iost could be either C- or P-, quit if it is a printer
Q:IOST["P-"
Q:'$D(^RMPR(664.1,PRDA,0)) ; p50 LAB issue problem not setting 664.1
Q:$P(^RMPR(664.1,PRDA,0),U,20) N D0 D GET^RMPR29W(PRDA) Q:'$D(RCK)
SGL ;DISPLAY JOB SECTION INFO
;EXPECTS ^UTILITY("DIQ1",$J,644.1, ARRAY TO BE SET UP.
;
;p50 - remove PRDA from NEWED vars.
N LC,MC,PAGE,SCH,SRC,TLC,TMC,TSH,TYPE
;RMPRBCK is set from RMPRPAT3, display extended screen from
;page 4 of the 2319 record.
I IOST["C-",'$D(RMPRBCK) N DIR S DIR(0)="E" D ^DIR
S (PAGE,MC,LC,TMC,TLC,TSH)=0 D HDR^RMPR29W(RMPRDA) S RI=$O(RCK(0)),(RJ,RTHD)=0
ITD ;item display
G:($Y+6>IOSL)!(RI'>0) MORE D ITM S RMPRWO=$P(RCK(RI),U,3)
TCH ;Check technician on work order
G:'$D(TECH(RMPRWO))!($O(TECH(RMPRWO,0))'>0) MU
S RTCD=$O(TECH(RMPRWO,0))
G:($Y+6>IOSL) MORE S RTC=$O(TECH(RMPRWO,RTCD,664.33,0))
I RTC D TDSP G TCH
MU ;display work order
G:($Y+3>IOSL) MORE
I $D(TMP(RMPRWO,664.22)) S RJ=$O(TMP(RMPRWO,664.22,0)) I RJ D MDSP G MU
S SCH=^UTILITY("DIQ1",$J,664.2,RMPRWO,4,"E")
I +SCH S:^UTILITY("DIQ1",$J,664.2,RMPRWO,5,"E") SCH=^("E") S TSH=TSH+SCH W !,?37,"SHIPPING CHARGE: ",?70,$J(SCH,10,2)
EXT ;display work order
G:($Y+6>IOSL) MORE S RW=$O(^UTILITY($J,"TEXT",RMPRWO,0))
I RW D WDSP G EXT
W !,RMPR("L")
S RI=$O(RCK(RI)) G ITD
MORE ;DISPLAY MORE INFO
;
;p50 ensure next page prompt is asked if not all data displayed
I IOST["C-",$Y>(IOSL-6) D
. W:$Y<(IOSL-5) !!
. N DIR S DIR(0)="E" D ^DIR W @IOF
. Q
G:+RI'>0 EXIT
G:'$D(PRDA) EXIT
S RMPRWO=$P(RCK(RI),U,3)
I $D(^UTILITY($J,"TEXT",RMPRWO)) S RMPRWZ=1
I $D(TECH(RMPRWO)) S RMPRTZ=1
I $D(TMP(RMPRWO,664.22)) S RMPRIZ=1
I $O(RCK(RI)) S RMPRCZ=1
I (+RI>0),$D(RMPRTZ) K RMPRTZ,RMPRIZ,RMPRCZ,RMPRWZ D HDR^RMPR29W(PRDA),ITM G TCH
I (+RI>0),$D(RMPRIZ) K RMPRIZ,RMPRCZ,RMPRWZ D HDR^RMPR29W(PRDA),ITM G MU
I (+RI>0),$D(RMPRWZ) K RMPRWZ,RMPRCZ D HDR^RMPR29W(PRDA),ITM G EXT
I $D(RMPRCZ),+RI K RMPRCZ S RI=$O(RCK(RI)) G:+RI'>0 EXIT D HDR^RMPR29W(PRDA) G ITD
G EXIT
ITM ;DISPLAY ITEM
W !,"JOB#:",?6,"("_RI_")",?10,"ITM#: "_$P(RCK(RI),U),?25,$E(^UTILITY("DIQ1",$J,664.16,$P(RCK(RI),U,4),.01),1,25),?54,"DATE MEASURED: "_$$FMTE^XLFDT(^UTILITY("DIQ1",$J,664.2,$P(RCK(RI),U,3),10,"I"),2)
W !,"DATE COMPLETED: "_$$FMTE^XLFDT(^UTILITY("DIQ1",$J,664.2,$P(RCK(RI),U,3),8,"I"),2)
W ?25,"COMPLETED BY: "_$E(^UTILITY("DIQ1",$J,664.2,$P(RCK(RI),U,3),9,"E"),1,14),?54,"CHECKED BY: "_$E(^UTILITY("DIQ1",$J,664.2,$P(RCK(RI),U,3),11,"E"),1,14),!
Q
AMC ;GET AMIS CODES FROM 660
S PZD=$G(^RMPR(661,$P($G(^RMPR(660,+$P($G(RCK(RI)),U,2),0)),U,6),0)) G DA
ADC(RD0,RD1) ;SEARCH AMIS ITEM
K RLAB
I '$D(PZD),$D(RD0),$D(RD1) D
.S:$P(^RMPR(664.1,RD0,0),U,15)=$G(RMPR("STA")) RLAB=1
.S PZD=$G(^RMPR(661,$P($G(^RMPR(664.1,RD0,2,RD1,0)),U),0))
.S TYPE=$P(^RMPR(664.1,RD0,2,RD1,0),U,7)
.S SRC=$P(^RMPR(664.1,RD0,0),U,11)
DA ;DISPLAY SINGLE ITEM AMIS
;restoration repair
;new line
Q:'$D(SRC)
I TYPE="X",SRC="R" D
.X $S($D(D0):"W !,?9",1:"W !,?10")
.W "ADMIN REPAIR CODE: ",$P($G(^RMPR(663,+$P(PZD,U,4),0)),U)
.W:$D(RLAB) ?50,"RESTORATION REPAIR CODE: ",$P($G(^RMPR(663,+$P(PZD,U,8),0)),U)
;ortho repair
I TYPE="X",SRC'="R" D
.X $S($D(D0):"W !,?9",1:"W !,?10")
.W "ADMIN REPAIR CODE: ",$P($G(^RMPR(663,+$P(PZD,U,4),0)),U)
.W:$D(RLAB) ?50,"ORTHO REPAIR CODE: ",$P($G(^RMPR(663,+$P(PZD,U,6),0)),U)
;ortho new
I TYPE'="X",SRC'="R" D
.X $S($D(D0):"W !,?9",1:"W !,?10")
.W "ADMIN NEW CODE: ",$P($G(^RMPR(663,+$P(PZD,U,3),0)),U)
.W:$D(RLAB) ?50,"ORTHO NEW CODE: ",$P($G(^RMPR(663,+$P(PZD,U,5),0)),U)
;restoration new
I TYPE'="X",SRC="R" D
.X $S($D(D0):"W !,?9",1:"W !,?10")
.W "ADMIN NEW CODE: ",$P($G(^RMPR(663,+$P(PZD,U,3),0)),U)
.W:$D(RLAB) ?50,"RESTORATION NEW CODE: ",$P($G(^RMPR(663,+$P(PZD,U,7),0)),U)
K PZD,RLAB,RD0,RD1 Q
MDSP ;DISPLAY MATERIALS
W !,"MATERIALS:",?15,$E(TMP(RMPRWO,664.22,RJ,.01),1,20)
W ?37,TMP(RMPRWO,664.22,RJ,1),?42,TMP(RMPRWO,664.22,RJ,6)
W ?47,$E(TMP(RMPRWO,664.22,RJ,3),1),?53,$J(TMP(RMPRWO,664.22,RJ,2),7,2)
S MC=TMP(RMPRWO,664.22,RJ,1)*TMP(RMPRWO,664.22,RJ,2),TMC=TMC+MC
W ?64,"TOTAL:",?69,$J(MC,10,2)
I $G(TMP(RMPRWO,664.22,RJ,10))'="" D
.S RVA=$O(^RMPR(660,"E",TMP(RMPRWO,664.22,RJ,10),0))
.W !,?15,TMP(RMPRWO,664.22,RJ,10)
.I $D(^RMPR(660,+RVA,0)) S RDEL=$P(^(0),U,12) W ?37,"DATE DELIVERED: ",?53,$$FMTE^XLFDT(RDEL,2)
K TMP(RMPRWO,664.22,RJ)
Q
TDSP ;DISPLAY TECHNICIAN
W !,"DATE:",?6,$$FMTE^XLFDT(RTCD,2)
W ?15,$E(TECH(RMPRWO,RTCD,664.33,RTC,.01,"E"),1,20),?37,"HRS"
W ?42,TECH(RMPRWO,RTCD,664.33,RTC,1,"E"),?47,"RATE:"
S RTR=TECH(RMPRWO,RTCD,664.33,RTC,2,"I") W ?53,$J(RTR,7,2)
S LC=TECH(RMPRWO,RTCD,664.33,RTC,1,"I")*RTR,TLC=TLC+LC
W ?64,"TOTAL:",$J(LC,10,2) K TECH(RMPRWO,RTCD,664.33,RTC) S RTHD=RTCD
Q
WDSP ;DISPLAY REMARKS FIELD
W !,^UTILITY($J,"TEXT",RMPRWO,RW)
K ^UTILITY($J,"TEXT",RMPRWO,RW),RR Q
EXIT ;common exit point
W !,?45,"TOTAL LABOR COST: ",?69,$J(TLC,10,2)
W !,?45,"TOTAL MATERIAL COST:",?69,$J(TMC+TSH,10,2)
W !,?45,"TOTAL COST",?69,$J(TLC+TMC,10,2)
;D MORE ;I IOST["C-" W !,"Press 'RETURN' to continue:" ;R !,"Press RETURN to Continue:",RX:DTIME W "KEY PRESSED !" I '$T Q
N DIR S DIR(0)="E" D ^DIR W @IOF
K TECH,TMP,RDEL,RCK,RI,RJ,RP,RTC,RTCD,RTHD,RTR,RVA,RW,RX
I $G(RMPRBAC1)>0 Q
I $G(RMPRDA)'>0 K RMPRBAC1,RMPRDA,RMPRWO Q
K RMPRWO Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR293 6100 printed Dec 13, 2024@02:32:01 Page 2
RMPR293 ;PHX/JLT/HNB -DISPLAY JOB RECORD INFO ;[ 10/04/94 10:15 AM ]
+1 ;;3.0;PROSTHETICS;**50**;Feb 09, 1996
+2 ;
+3 ; ODJ - patch 50 - 7/14/00 - fix display problem which is causing
+4 ; remarks not to be displayed
+5 ; NOIS CTX-0197-70330
+6 ; - patch 50 - 7/18/00 - prevent crash at DISP+8 see NOIS's
+7 ; FGH-1099-30059, KAN-0500-40811
+8 ;
DISP(PRDA) ;CALLED FROM TEMPLATE [RMPR 25293] AND RMPRPRT
+1 ; VARIABLES REQUIRED: RMPRDA - ENTRY IN FILE 664.1
+2 ; PRDA - ENTRY IN FILE 664.1 (COPY PASSED IN)
+3 ; RMPR("L") - A LINE OF '-'S
+4 if $GET(PRDA)'>1
QUIT
+5 ;disp is called from RMPR29R, and print template [RMPR 25293]
+6 ;iost could be either C- or P-, quit if it is a printer
+7 if IOST["P-"
QUIT
+8 ; p50 LAB issue problem not setting 664.1
if '$DATA(^RMPR(664.1,PRDA,0))
QUIT
+9 if $PIECE(^RMPR(664.1,PRDA,0),U,20)
QUIT
NEW D0
DO GET^RMPR29W(PRDA)
if '$DATA(RCK)
QUIT
SGL ;DISPLAY JOB SECTION INFO
+1 ;EXPECTS ^UTILITY("DIQ1",$J,644.1, ARRAY TO BE SET UP.
+2 ;
+3 ;p50 - remove PRDA from NEWED vars.
+4 NEW LC,MC,PAGE,SCH,SRC,TLC,TMC,TSH,TYPE
+5 ;RMPRBCK is set from RMPRPAT3, display extended screen from
+6 ;page 4 of the 2319 record.
+7 IF IOST["C-"
IF '$DATA(RMPRBCK)
NEW DIR
SET DIR(0)="E"
DO ^DIR
+8 SET (PAGE,MC,LC,TMC,TLC,TSH)=0
DO HDR^RMPR29W(RMPRDA)
SET RI=$ORDER(RCK(0))
SET (RJ,RTHD)=0
ITD ;item display
+1 if ($Y+6>IOSL)!(RI'>0)
GOTO MORE
DO ITM
SET RMPRWO=$PIECE(RCK(RI),U,3)
TCH ;Check technician on work order
+1 if '$DATA(TECH(RMPRWO))!($ORDER(TECH(RMPRWO,0))'>0)
GOTO MU
+2 SET RTCD=$ORDER(TECH(RMPRWO,0))
+3 if ($Y+6>IOSL)
GOTO MORE
SET RTC=$ORDER(TECH(RMPRWO,RTCD,664.33,0))
+4 IF RTC
DO TDSP
GOTO TCH
MU ;display work order
+1 if ($Y+3>IOSL)
GOTO MORE
+2 IF $DATA(TMP(RMPRWO,664.22))
SET RJ=$ORDER(TMP(RMPRWO,664.22,0))
IF RJ
DO MDSP
GOTO MU
+3 SET SCH=^UTILITY("DIQ1",$JOB,664.2,RMPRWO,4,"E")
+4 IF +SCH
if ^UTILITY("DIQ1",$JOB,664.2,RMPRWO,5,"E")
SET SCH=^("E")
SET TSH=TSH+SCH
WRITE !,?37,"SHIPPING CHARGE: ",?70,$JUSTIFY(SCH,10,2)
EXT ;display work order
+1 if ($Y+6>IOSL)
GOTO MORE
SET RW=$ORDER(^UTILITY($JOB,"TEXT",RMPRWO,0))
+2 IF RW
DO WDSP
GOTO EXT
+3 WRITE !,RMPR("L")
+4 SET RI=$ORDER(RCK(RI))
GOTO ITD
MORE ;DISPLAY MORE INFO
+1 ;
+2 ;p50 ensure next page prompt is asked if not all data displayed
+3 IF IOST["C-"
IF $Y>(IOSL-6)
Begin DoDot:1
+4 if $Y<(IOSL-5)
WRITE !!
+5 NEW DIR
SET DIR(0)="E"
DO ^DIR
WRITE @IOF
+6 QUIT
End DoDot:1
+7 if +RI'>0
GOTO EXIT
+8 if '$DATA(PRDA)
GOTO EXIT
+9 SET RMPRWO=$PIECE(RCK(RI),U,3)
+10 IF $DATA(^UTILITY($JOB,"TEXT",RMPRWO))
SET RMPRWZ=1
+11 IF $DATA(TECH(RMPRWO))
SET RMPRTZ=1
+12 IF $DATA(TMP(RMPRWO,664.22))
SET RMPRIZ=1
+13 IF $ORDER(RCK(RI))
SET RMPRCZ=1
+14 IF (+RI>0)
IF $DATA(RMPRTZ)
KILL RMPRTZ,RMPRIZ,RMPRCZ,RMPRWZ
DO HDR^RMPR29W(PRDA)
DO ITM
GOTO TCH
+15 IF (+RI>0)
IF $DATA(RMPRIZ)
KILL RMPRIZ,RMPRCZ,RMPRWZ
DO HDR^RMPR29W(PRDA)
DO ITM
GOTO MU
+16 IF (+RI>0)
IF $DATA(RMPRWZ)
KILL RMPRWZ,RMPRCZ
DO HDR^RMPR29W(PRDA)
DO ITM
GOTO EXT
+17 IF $DATA(RMPRCZ)
IF +RI
KILL RMPRCZ
SET RI=$ORDER(RCK(RI))
if +RI'>0
GOTO EXIT
DO HDR^RMPR29W(PRDA)
GOTO ITD
+18 GOTO EXIT
ITM ;DISPLAY ITEM
+1 WRITE !,"JOB#:",?6,"("_RI_")",?10,"ITM#: "_$PIECE(RCK(RI),U),?25,$EXTRACT(^UTILITY("DIQ1",$JOB,664.16,$PIECE(RCK(RI),U,4),.01),1,25),?54,"DATE MEASURED: "_$$FMTE^XLFDT(^UTILITY("DIQ1",$JOB,664.2,$PIECE(RCK(RI),U,3),10,"I"),2)
+2 WRITE !,"DATE COMPLETED: "_$$FMTE^XLFDT(^UTILITY("DIQ1",$JOB,664.2,$PIECE(RCK(RI),U,3),8,"I"),2)
+3 WRITE ?25,"COMPLETED BY: "_$EXTRACT(^UTILITY("DIQ1",$JOB,664.2,$PIECE(RCK(RI),U,3),9,"E"),1,14),?54,"CHECKED BY: "_$EXTRACT(^UTILITY("DIQ1",$JOB,664.2,$PIECE(RCK(RI),U,3),11,"E"),1,14),!
+4 QUIT
AMC ;GET AMIS CODES FROM 660
+1 SET PZD=$GET(^RMPR(661,$PIECE($GET(^RMPR(660,+$PIECE($GET(RCK(RI)),U,2),0)),U,6),0))
GOTO DA
ADC(RD0,RD1) ;SEARCH AMIS ITEM
+1 KILL RLAB
+2 IF '$DATA(PZD)
IF $DATA(RD0)
IF $DATA(RD1)
Begin DoDot:1
+3 if $PIECE(^RMPR(664.1,RD0,0),U,15)=$GET(RMPR("STA"))
SET RLAB=1
+4 SET PZD=$GET(^RMPR(661,$PIECE($GET(^RMPR(664.1,RD0,2,RD1,0)),U),0))
+5 SET TYPE=$PIECE(^RMPR(664.1,RD0,2,RD1,0),U,7)
+6 SET SRC=$PIECE(^RMPR(664.1,RD0,0),U,11)
End DoDot:1
DA ;DISPLAY SINGLE ITEM AMIS
+1 ;restoration repair
+2 ;new line
+3 if '$DATA(SRC)
QUIT
+4 IF TYPE="X"
IF SRC="R"
Begin DoDot:1
+5 XECUTE $SELECT($DATA(D0):"W !,?9",1:"W !,?10")
+6 WRITE "ADMIN REPAIR CODE: ",$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,4),0)),U)
+7 if $DATA(RLAB)
WRITE ?50,"RESTORATION REPAIR CODE: ",$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,8),0)),U)
End DoDot:1
+8 ;ortho repair
+9 IF TYPE="X"
IF SRC'="R"
Begin DoDot:1
+10 XECUTE $SELECT($DATA(D0):"W !,?9",1:"W !,?10")
+11 WRITE "ADMIN REPAIR CODE: ",$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,4),0)),U)
+12 if $DATA(RLAB)
WRITE ?50,"ORTHO REPAIR CODE: ",$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,6),0)),U)
End DoDot:1
+13 ;ortho new
+14 IF TYPE'="X"
IF SRC'="R"
Begin DoDot:1
+15 XECUTE $SELECT($DATA(D0):"W !,?9",1:"W !,?10")
+16 WRITE "ADMIN NEW CODE: ",$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,3),0)),U)
+17 if $DATA(RLAB)
WRITE ?50,"ORTHO NEW CODE: ",$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,5),0)),U)
End DoDot:1
+18 ;restoration new
+19 IF TYPE'="X"
IF SRC="R"
Begin DoDot:1
+20 XECUTE $SELECT($DATA(D0):"W !,?9",1:"W !,?10")
+21 WRITE "ADMIN NEW CODE: ",$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,3),0)),U)
+22 if $DATA(RLAB)
WRITE ?50,"RESTORATION NEW CODE: ",$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,7),0)),U)
End DoDot:1
+23 KILL PZD,RLAB,RD0,RD1
QUIT
MDSP ;DISPLAY MATERIALS
+1 WRITE !,"MATERIALS:",?15,$EXTRACT(TMP(RMPRWO,664.22,RJ,.01),1,20)
+2 WRITE ?37,TMP(RMPRWO,664.22,RJ,1),?42,TMP(RMPRWO,664.22,RJ,6)
+3 WRITE ?47,$EXTRACT(TMP(RMPRWO,664.22,RJ,3),1),?53,$JUSTIFY(TMP(RMPRWO,664.22,RJ,2),7,2)
+4 SET MC=TMP(RMPRWO,664.22,RJ,1)*TMP(RMPRWO,664.22,RJ,2)
SET TMC=TMC+MC
+5 WRITE ?64,"TOTAL:",?69,$JUSTIFY(MC,10,2)
+6 IF $GET(TMP(RMPRWO,664.22,RJ,10))'=""
Begin DoDot:1
+7 SET RVA=$ORDER(^RMPR(660,"E",TMP(RMPRWO,664.22,RJ,10),0))
+8 WRITE !,?15,TMP(RMPRWO,664.22,RJ,10)
+9 IF $DATA(^RMPR(660,+RVA,0))
SET RDEL=$PIECE(^(0),U,12)
WRITE ?37,"DATE DELIVERED: ",?53,$$FMTE^XLFDT(RDEL,2)
End DoDot:1
+10 KILL TMP(RMPRWO,664.22,RJ)
+11 QUIT
TDSP ;DISPLAY TECHNICIAN
+1 WRITE !,"DATE:",?6,$$FMTE^XLFDT(RTCD,2)
+2 WRITE ?15,$EXTRACT(TECH(RMPRWO,RTCD,664.33,RTC,.01,"E"),1,20),?37,"HRS"
+3 WRITE ?42,TECH(RMPRWO,RTCD,664.33,RTC,1,"E"),?47,"RATE:"
+4 SET RTR=TECH(RMPRWO,RTCD,664.33,RTC,2,"I")
WRITE ?53,$JUSTIFY(RTR,7,2)
+5 SET LC=TECH(RMPRWO,RTCD,664.33,RTC,1,"I")*RTR
SET TLC=TLC+LC
+6 WRITE ?64,"TOTAL:",$JUSTIFY(LC,10,2)
KILL TECH(RMPRWO,RTCD,664.33,RTC)
SET RTHD=RTCD
+7 QUIT
WDSP ;DISPLAY REMARKS FIELD
+1 WRITE !,^UTILITY($JOB,"TEXT",RMPRWO,RW)
+2 KILL ^UTILITY($JOB,"TEXT",RMPRWO,RW),RR
QUIT
EXIT ;common exit point
+1 WRITE !,?45,"TOTAL LABOR COST: ",?69,$JUSTIFY(TLC,10,2)
+2 WRITE !,?45,"TOTAL MATERIAL COST:",?69,$JUSTIFY(TMC+TSH,10,2)
+3 WRITE !,?45,"TOTAL COST",?69,$JUSTIFY(TLC+TMC,10,2)
+4 ;D MORE ;I IOST["C-" W !,"Press 'RETURN' to continue:" ;R !,"Press RETURN to Continue:",RX:DTIME W "KEY PRESSED !" I '$T Q
+5 NEW DIR
SET DIR(0)="E"
DO ^DIR
WRITE @IOF
+6 KILL TECH,TMP,RDEL,RCK,RI,RJ,RP,RTC,RTCD,RTHD,RTR,RVA,RW,RX
+7 IF $GET(RMPRBAC1)>0
QUIT
+8 IF $GET(RMPRDA)'>0
KILL RMPRBAC1,RMPRDA,RMPRWO
QUIT
+9 KILL RMPRWO
QUIT