- 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 Feb 19, 2025@00:00:36 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
