RMPRD1 ;PHX/HNB-DISPLAY LOOKUP ;10/19/1993 [ 06/28/94 3:17 PM ]<<= NOT VERIFIED >
;;3.0;PROSTHETICS;**38,141**;Feb 09, 1996;Build 5
EN ;DISPLAY DATE,PATIENT,ITEM,COST FROM 660
S Z=^RMPR(660,+Y,0)
S RMPRIT=$P(Z,U,6)
I RMPRIT'="" S RMPRIT=$P(^RMPR(661,RMPRIT,0),U,1),RMPRIT=$P(^PRC(441,RMPRIT,0),U,2)
I RMPRIT="" S RMPRIT=$S($P(^RMPR(660,+Y,0),U,26)="P":"SHIPPING",$P(^RMPR(660,+Y,0),U,26)="D":"DELIVERY",1:"SHIPPING")
S RMPRCST="$"_$J($FN($P(Z,U,16),"T",2),8)
W ?36,$E(RMPRIT,1,23),?70,RMPRCST
K RMPRDFN,RMPRNAM,RMPRIT,RMPRCST,Z
Q
EN1 ;DISPLAY DATE,REFERENCE,PATIENT FROM 664
Q:$G(RMPRQT)=1
I $G(DIC)="^RMPR(664," S Z=^RMPR(664,+Y,0),ZZ=$P(Z,U,7)
W:$P(Z,U,8) ?40,"Closed" W:$P(Z,U,5) ?40,"Cancelled"
W:$G(ZZ)'="" ?51,"REF: ",$P(ZZ,"-",3)
I $G(ZZ)="",$P(Z,U,15),$D(^RMPR(664.2,+$P(Z,U,15),0)) W ?40,$P(^(0),U)
I $D(^RMPR(664,+Y,1,0)) D
.S RMPRI=0
.;F S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0
.;S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1)
.F S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0 D
..S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1) Q:$G(RMPRI1)'>0
..S RMPRIT=$P($G(^RMPR(661,RMPRI1,0)),U,1)
..S:RMPRIT RMPRN=$P(^PRC(441,RMPRIT,0),U,2) S:RMPRIT="" RMPRN="*MASTER ITEM DELETED*"
..W ?64,$E(RMPRN,1,15)
..I $O(^RMPR(664,+Y,1,RMPRI)) W !
I '$D(^RMPR(664,+Y,1)),$P(^RMPR(664,+Y,0),U,12) W ?64,"PICKUP/DELIVERY",!
K ZZ Q
EN2 ;DISPLAY NAME
I DIC="^RMPR(664," S Z=$P(^RMPR(664,+Y,0),U,2) I +Z W ?20,$E($P(^DPT(+Z,0),U,1),1,15) G EN1
Q
EN3 ;DISPLAY LAB ORDER
I $P(^RMPR(664.1,+Y,0),U,13)="" D EN4 Q
S Z=$P(^RMPR(664.1,+Y,0),U,2)
I +Z W ?20,$E($P(^DPT(+Z,0),U,1),1,15),?40,$P(^RMPR(664.1,+Y,0),U,13),?57,$P(^(0),U,17) I $D(^RMPR(664.1,+Y,2)) D
.F RMPRI=0:0 S RMPRI=$O(^RMPR(664.1,+Y,2,RMPRI)) Q:RMPRI'>0 I $D(^(RMPRI,0)) S ZA=$P(^(0),U,1) W ?64,$E($$ITM^RMPR31U(ZA),1,15) I $O(^RMPR(664.1,+Y,2,RMPRI)) W !
Q
EN4 ;DISPLAY 2529-3 REQUEST
S Z=^RMPR(664.1,+Y,0)
I +$P(Z,U,2) W ?20,$E($P(^DPT(+$P(Z,U,2),0),U,1),1,15) S RMPRSC=$P(Z,U,11),ZA=$P(^DD(664.1,2,0),U,3) W:RMPRSC'="" ?40,$E($P($P(ZA,RMPRSC_":",2),";",1),1,15)_"-"_$$STAN^RMPR31U($P(Z,U,15)) I $D(^RMPR(664.1,+Y,2)) D
.F RMPRI=0:0 S RMPRI=$O(^RMPR(664.1,+Y,2,RMPRI)) Q:RMPRI'>0 I $D(^(RMPRI,0)) S ZA=$P(^(0),U,1) W ?64,$E($$ITM^RMPR31U(ZA),1,15) I $O(^RMPR(664.1,+Y,2,RMPRI)) W !
Q
EN5 ;Inquire to 1358 transaction
I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X)
N DIC
S RMPRQT=1
S DIC="^RMPR(664,",DIC(0)="AEQMZ" ;,DIC("W")="D EN2^RMPRD1"
;S %ZIS="MQ" D ^%ZIS G:POP EXIT
K IOP I $E(IOST,1,1)["C-" G EN6
S DIC("S")="I $P(^(0),U,14)=RMPR(""STA"")"
D ^DIC Q:Y'>0
S RMPRDA=+Y
S %ZIS="MQ" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
.S ZTSAVE("RMPRDA")="",ZTSAVE("RMPR(")=""
.S ZTSAVE("DATE(")="",ZTSAVE("RMPRSITE")=""
.S ZTIO=ION,ZTRTN="EN6^RMPRD1",ZTDESC="Inquire To Prosthetics 1358"
.D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE
;ENTRY POINT FOR ACTUAL PRINTING OF 1358 INFO TO PRINTER OR SCREEN
;S DIC("S")="I $P(^(0),U,14)=RMPR(""STA"")"
; D ^DIC Q:Y'>0
EN6 N RPO,RPO1 K DR
S DA=RMPRDA,DIQ="RPO",DR=".01:24",RMPRDA=DA
D EN^DIQ1
S DR(664.02)=".01:16"
S RPO1=0
F S RPO1=$O(^RMPR(664,DA,1,RPO1)) Q:RPO1'>0 D
.S DA(664.02)=RPO1
.D EN^DIQ1
;Display
U IO
I $Y>1 W @IOF
W "Patient: ",RPO(664,RMPRDA,1),?40,"Vendor:",RPO(664,RMPRDA,4)
W !,"Request Date: ",RPO(664,RMPRDA,.01),?33,"Date Required: ",RPO(664,RMPRDA,20),?69,"Days: ",RPO(664,RMPRDA,21)
W !,"Form: ",RPO(664,RMPRDA,15),?33,"Initiator: ",$E(RPO(664,RMPRDA,10),1,12),?60,"Sta.: ",$E(RPO(664,RMPRDA,18),1,11)
I $G(RPO(664,RMPRDA,8))'="" D
.W !!,"Close Out Date:",RPO(664,RMPRDA,8),?40,"Closed By:",RPO(664,RMPRDA,8.5)
.W !,"Remarks: ",RPO(664,RMPRDA,8.1)
I $G(RPO(664,RMPRDA,12))'="" D
.W !!,"Shipping Entry: ",RPO(664,RMPRDA,13)
.W ?40,"Shipping Charge: ",RPO(664,RMPRDA,12)
I $G(RPO(664,RMPRDA,3))'="" D
.W !!,"Canceled Date: ",RPO(664,RMPRDA,3),?40,"Canceled By: ",RPO(664,RMPRDA,3.2)
.W !,"Cancelation Remarks: ",RPO(664,RMPRDA,3.1)
I $G(RPO(664,RMPRDA,22))'="" D
.W !!,"Work Order #: ",RPO(664,RMPRDA,22),?33,"Lab Tech.: ",$E(RPO(664,RMPRDA,23),1,12),?60,"Date: ",RPO(664,RMPRDA,24)
W !!,"Obligation #:",RPO(664,RMPRDA,.5)
W ?35,"C.P.:",RPO(664,RMPRDA,6)
W !,"Reference: ",RPO(664,RMPRDA,7)
W ?35,"% Discount: ",RPO(664,RMPRDA,17)
W ?60,"PSC Category: ",RPO(664,RMPRDA,16)
;Item Mult. Display
S RD1=0 F S RD1=$O(^RMPR(664,DA,1,RD1)) Q:$G(RD1)'>0 D
.W !!,"Item:",RPO(664.02,RD1,.01)
.W ?34,"Qty:",RPO(664.02,RD1,3)_" "_RPO(664.02,RD1,4)
.W ?60,"Unit Cost :",RPO(664.02,RD1,2)
.W !,?2,"Actual Unit Cost: ",RPO(664.02,RD1,2)
.W ?34,"Source:",RPO(664.02,RD1,11)
.W ?60,"Serial #:",RPO(664.02,RD1,15)
.W !,?2,"Patient Category: ",RPO(664.02,RD1,9),?34,"Type of Transaction: ",RPO(664.02,RD1,9)
.W !,?2,"Special Category: ",RPO(664.02,RD1,10),?34,"Appliance/Repair: ",RPO(664.02,RD1,12)
.W !!,?2,"Item Remarks: ",RPO(664.02,RD1,7)
;W !!,"READY TO WRITE WORD PROCESSING FIELDS"
S RPO1=0
F S RPO1=$O(RPO(664.02,RPO1)) Q:RPO1'>0 D
.W !,?2,"Brief Description: ",RPO(664.02,RPO1,1)
.W !,?2,"Extended Description:"
.M RPOD=RPO(664.02,RPO1,14)
.D EN^DDIOL(.RPOD)
.K RPOD
.W !!
;end
N DIR
I $Y>11&($G(IO("Q"))<1) S DIR(0)="E" D ^DIR
EXIT ;EXIT FROM EN5/EN6
K DA,RMPRDA,RMPRQT,RPO,IO("Q")
D ^%ZISC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRD1 5310 printed Dec 13, 2024@02:34:08 Page 2
RMPRD1 ;PHX/HNB-DISPLAY LOOKUP ;10/19/1993 [ 06/28/94 3:17 PM ]<<= NOT VERIFIED >
+1 ;;3.0;PROSTHETICS;**38,141**;Feb 09, 1996;Build 5
EN ;DISPLAY DATE,PATIENT,ITEM,COST FROM 660
+1 SET Z=^RMPR(660,+Y,0)
+2 SET RMPRIT=$PIECE(Z,U,6)
+3 IF RMPRIT'=""
SET RMPRIT=$PIECE(^RMPR(661,RMPRIT,0),U,1)
SET RMPRIT=$PIECE(^PRC(441,RMPRIT,0),U,2)
+4 IF RMPRIT=""
SET RMPRIT=$SELECT($PIECE(^RMPR(660,+Y,0),U,26)="P":"SHIPPING",$PIECE(^RMPR(660,+Y,0),U,26)="D":"DELIVERY",1:"SHIPPING")
+5 SET RMPRCST="$"_$JUSTIFY($FNUMBER($PIECE(Z,U,16),"T",2),8)
+6 WRITE ?36,$EXTRACT(RMPRIT,1,23),?70,RMPRCST
+7 KILL RMPRDFN,RMPRNAM,RMPRIT,RMPRCST,Z
+8 QUIT
EN1 ;DISPLAY DATE,REFERENCE,PATIENT FROM 664
+1 if $GET(RMPRQT)=1
QUIT
+2 IF $GET(DIC)="^RMPR(664,"
SET Z=^RMPR(664,+Y,0)
SET ZZ=$PIECE(Z,U,7)
+3 if $PIECE(Z,U,8)
WRITE ?40,"Closed"
if $PIECE(Z,U,5)
WRITE ?40,"Cancelled"
+4 if $GET(ZZ)'=""
WRITE ?51,"REF: ",$PIECE(ZZ,"-",3)
+5 IF $GET(ZZ)=""
IF $PIECE(Z,U,15)
IF $DATA(^RMPR(664.2,+$PIECE(Z,U,15),0))
WRITE ?40,$PIECE(^(0),U)
+6 IF $DATA(^RMPR(664,+Y,1,0))
Begin DoDot:1
+7 SET RMPRI=0
+8 ;F S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0
+9 ;S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1)
+10 FOR
SET RMPRI=$ORDER(^RMPR(664,+Y,1,RMPRI))
if $GET(RMPRI)'>0
QUIT
Begin DoDot:2
+11 SET RMPRI1=$PIECE(^RMPR(664,+Y,1,RMPRI,0),U,1)
if $GET(RMPRI1)'>0
QUIT
+12 SET RMPRIT=$PIECE($GET(^RMPR(661,RMPRI1,0)),U,1)
+13 if RMPRIT
SET RMPRN=$PIECE(^PRC(441,RMPRIT,0),U,2)
if RMPRIT=""
SET RMPRN="*MASTER ITEM DELETED*"
+14 WRITE ?64,$EXTRACT(RMPRN,1,15)
+15 IF $ORDER(^RMPR(664,+Y,1,RMPRI))
WRITE !
End DoDot:2
End DoDot:1
+16 IF '$DATA(^RMPR(664,+Y,1))
IF $PIECE(^RMPR(664,+Y,0),U,12)
WRITE ?64,"PICKUP/DELIVERY",!
+17 KILL ZZ
QUIT
EN2 ;DISPLAY NAME
+1 IF DIC="^RMPR(664,"
SET Z=$PIECE(^RMPR(664,+Y,0),U,2)
IF +Z
WRITE ?20,$EXTRACT($PIECE(^DPT(+Z,0),U,1),1,15)
GOTO EN1
+2 QUIT
EN3 ;DISPLAY LAB ORDER
+1 IF $PIECE(^RMPR(664.1,+Y,0),U,13)=""
DO EN4
QUIT
+2 SET Z=$PIECE(^RMPR(664.1,+Y,0),U,2)
+3 IF +Z
WRITE ?20,$EXTRACT($PIECE(^DPT(+Z,0),U,1),1,15),?40,$PIECE(^RMPR(664.1,+Y,0),U,13),?57,$PIECE(^(0),U,17)
IF $DATA(^RMPR(664.1,+Y,2))
Begin DoDot:1
+4 FOR RMPRI=0:0
SET RMPRI=$ORDER(^RMPR(664.1,+Y,2,RMPRI))
if RMPRI'>0
QUIT
IF $DATA(^(RMPRI,0))
SET ZA=$PIECE(^(0),U,1)
WRITE ?64,$EXTRACT($$ITM^RMPR31U(ZA),1,15)
IF $ORDER(^RMPR(664.1,+Y,2,RMPRI))
WRITE !
End DoDot:1
+5 QUIT
EN4 ;DISPLAY 2529-3 REQUEST
+1 SET Z=^RMPR(664.1,+Y,0)
+2 IF +$PIECE(Z,U,2)
WRITE ?20,$EXTRACT($PIECE(^DPT(+$PIECE(Z,U,2),0),U,1),1,15)
SET RMPRSC=$PIECE(Z,U,11)
SET ZA=$PIECE(^DD(664.1,2,0),U,3)
if RMPRSC'=""
WRITE ?40,$EXTRACT($PIECE($PIECE(ZA,RMPRSC_":",2),";",1),1,15)_"-"_$$STAN^RMPR31U($PIECE(Z,U,15))
IF $DATA(^RMPR(664.1,+Y,2))
Begin DoDot:1
+3 FOR RMPRI=0:0
SET RMPRI=$ORDER(^RMPR(664.1,+Y,2,RMPRI))
if RMPRI'>0
QUIT
IF $DATA(^(RMPRI,0))
SET ZA=$PIECE(^(0),U,1)
WRITE ?64,$EXTRACT($$ITM^RMPR31U(ZA),1,15)
IF $ORDER(^RMPR(664.1,+Y,2,RMPRI))
WRITE !
End DoDot:1
+4 QUIT
EN5 ;Inquire to 1358 transaction
+1 IF '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+2 NEW DIC
+3 SET RMPRQT=1
+4 ;,DIC("W")="D EN2^RMPRD1"
SET DIC="^RMPR(664,"
SET DIC(0)="AEQMZ"
+5 ;S %ZIS="MQ" D ^%ZIS G:POP EXIT
+6 KILL IOP
IF $EXTRACT(IOST,1,1)["C-"
GOTO EN6
+7 SET DIC("S")="I $P(^(0),U,14)=RMPR(""STA"")"
+8 DO ^DIC
if Y'>0
QUIT
+9 SET RMPRDA=+Y
+10 SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
+11 IF $DATA(IO("Q"))
Begin DoDot:1
+12 SET ZTSAVE("RMPRDA")=""
SET ZTSAVE("RMPR(")=""
+13 SET ZTSAVE("DATE(")=""
SET ZTSAVE("RMPRSITE")=""
+14 SET ZTIO=ION
SET ZTRTN="EN6^RMPRD1"
SET ZTDESC="Inquire To Prosthetics 1358"
+15 DO ^%ZTLOAD
KILL ZTDESC,ZTIO,ZTRTN,ZTSAVE
End DoDot:1
GOTO EXIT
+16 ;ENTRY POINT FOR ACTUAL PRINTING OF 1358 INFO TO PRINTER OR SCREEN
+17 ;S DIC("S")="I $P(^(0),U,14)=RMPR(""STA"")"
+18 ; D ^DIC Q:Y'>0
EN6 NEW RPO,RPO1
KILL DR
+1 SET DA=RMPRDA
SET DIQ="RPO"
SET DR=".01:24"
SET RMPRDA=DA
+2 DO EN^DIQ1
+3 SET DR(664.02)=".01:16"
+4 SET RPO1=0
+5 FOR
SET RPO1=$ORDER(^RMPR(664,DA,1,RPO1))
if RPO1'>0
QUIT
Begin DoDot:1
+6 SET DA(664.02)=RPO1
+7 DO EN^DIQ1
End DoDot:1
+8 ;Display
+9 USE IO
+10 IF $Y>1
WRITE @IOF
+11 WRITE "Patient: ",RPO(664,RMPRDA,1),?40,"Vendor:",RPO(664,RMPRDA,4)
+12 WRITE !,"Request Date: ",RPO(664,RMPRDA,.01),?33,"Date Required: ",RPO(664,RMPRDA,20),?69,"Days: ",RPO(664,RMPRDA,21)
+13 WRITE !,"Form: ",RPO(664,RMPRDA,15),?33,"Initiator: ",$EXTRACT(RPO(664,RMPRDA,10),1,12),?60,"Sta.: ",$EXTRACT(RPO(664,RMPRDA,18),1,11)
+14 IF $GET(RPO(664,RMPRDA,8))'=""
Begin DoDot:1
+15 WRITE !!,"Close Out Date:",RPO(664,RMPRDA,8),?40,"Closed By:",RPO(664,RMPRDA,8.5)
+16 WRITE !,"Remarks: ",RPO(664,RMPRDA,8.1)
End DoDot:1
+17 IF $GET(RPO(664,RMPRDA,12))'=""
Begin DoDot:1
+18 WRITE !!,"Shipping Entry: ",RPO(664,RMPRDA,13)
+19 WRITE ?40,"Shipping Charge: ",RPO(664,RMPRDA,12)
End DoDot:1
+20 IF $GET(RPO(664,RMPRDA,3))'=""
Begin DoDot:1
+21 WRITE !!,"Canceled Date: ",RPO(664,RMPRDA,3),?40,"Canceled By: ",RPO(664,RMPRDA,3.2)
+22 WRITE !,"Cancelation Remarks: ",RPO(664,RMPRDA,3.1)
End DoDot:1
+23 IF $GET(RPO(664,RMPRDA,22))'=""
Begin DoDot:1
+24 WRITE !!,"Work Order #: ",RPO(664,RMPRDA,22),?33,"Lab Tech.: ",$EXTRACT(RPO(664,RMPRDA,23),1,12),?60,"Date: ",RPO(664,RMPRDA,24)
End DoDot:1
+25 WRITE !!,"Obligation #:",RPO(664,RMPRDA,.5)
+26 WRITE ?35,"C.P.:",RPO(664,RMPRDA,6)
+27 WRITE !,"Reference: ",RPO(664,RMPRDA,7)
+28 WRITE ?35,"% Discount: ",RPO(664,RMPRDA,17)
+29 WRITE ?60,"PSC Category: ",RPO(664,RMPRDA,16)
+30 ;Item Mult. Display
+31 SET RD1=0
FOR
SET RD1=$ORDER(^RMPR(664,DA,1,RD1))
if $GET(RD1)'>0
QUIT
Begin DoDot:1
+32 WRITE !!,"Item:",RPO(664.02,RD1,.01)
+33 WRITE ?34,"Qty:",RPO(664.02,RD1,3)_" "_RPO(664.02,RD1,4)
+34 WRITE ?60,"Unit Cost :",RPO(664.02,RD1,2)
+35 WRITE !,?2,"Actual Unit Cost: ",RPO(664.02,RD1,2)
+36 WRITE ?34,"Source:",RPO(664.02,RD1,11)
+37 WRITE ?60,"Serial #:",RPO(664.02,RD1,15)
+38 WRITE !,?2,"Patient Category: ",RPO(664.02,RD1,9),?34,"Type of Transaction: ",RPO(664.02,RD1,9)
+39 WRITE !,?2,"Special Category: ",RPO(664.02,RD1,10),?34,"Appliance/Repair: ",RPO(664.02,RD1,12)
+40 WRITE !!,?2,"Item Remarks: ",RPO(664.02,RD1,7)
End DoDot:1
+41 ;W !!,"READY TO WRITE WORD PROCESSING FIELDS"
+42 SET RPO1=0
+43 FOR
SET RPO1=$ORDER(RPO(664.02,RPO1))
if RPO1'>0
QUIT
Begin DoDot:1
+44 WRITE !,?2,"Brief Description: ",RPO(664.02,RPO1,1)
+45 WRITE !,?2,"Extended Description:"
+46 MERGE RPOD=RPO(664.02,RPO1,14)
+47 DO EN^DDIOL(.RPOD)
+48 KILL RPOD
+49 WRITE !!
End DoDot:1
+50 ;end
+51 NEW DIR
+52 IF $Y>11&($GET(IO("Q"))<1)
SET DIR(0)="E"
DO ^DIR
EXIT ;EXIT FROM EN5/EN6
+1 KILL DA,RMPRDA,RMPRQT,RPO,IO("Q")
+2 DO ^%ZISC
