- RMPR4D1 ;PHX/HNB -DISPLAY/LOOKUP/DIC(W) PURCHASE CARD ;3/1/1996
- ;;3.0;PROSTHETICS;**3**;Feb 09, 1996
- EN ;DISPLAY DATE,PATIENT,ITEM,COST FROM 660
- S Z=^RMPR(660,+Y,0)
- ;should call getpat instead.
- S RMPRDFN=$P(Z,U,2),RMPRNAM=$P(^DPT(RMPRDFN,0),U,1),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 ?25,$E(RMPRNAM,1,18),?45,$E(RMPRIT,1,23),?70,RMPRCST
- K RMPRDFN,RMPRNAM,RMPRIT,RMPRCST,Z Q
- EN1 ;DISPLAY DATE,REFERENCE,PATIENT FROM 664
- ;called from en2
- N RZ,RZZ
- Q:$G(RMPRQT)=1
- I $G(DIC)="^RMPR(664," S RZ=^RMPR(664,+Y,0),RZZ=$P(RZ,U,7)
- W:$P(RZ,U,8) ?49,"Closed" W:$P(RZ,U,5) ?49,"Cancelled"
- W:$G(^RMPR(664,+Y,4)) ?49,"BA:",$P(^(4),U,2)
- I $G(RZZ)="",$P(RZ,U,15),$D(^RMPR(664.2,+$P(RZ,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 D
- ..S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1) Q:$G(RMPRI1)'>0
- ..S RMPRIT=$P(^RMPR(661,RMPRI1,0),U,1)
- ..S RMPRN=$P(^PRC(441,RMPRIT,0),U,2)
- ..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",!
- Q
- EN2 ;DISPLAY NAME
- ;used for dic(w) only, file 664
- N RZ
- S RZ=$P(^RMPR(664,+Y,0),U,2) I +RZ W ?33,$E($P(^DPT(+RZ,0),U,1),1,15) G EN1
- Q
- EN5 ;Inquire to purchase card 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^RMPR4D1"
- K IOP I $E(IOST)["C" G EN6
- S DIC("S")="I $D(^(4)) 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 Purchase Card"
- .D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE
- EN6 ;Printinig Purchase Card
- 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)
- 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[HRMPR4D1 4293 printed Mar 13, 2025@21:37:36 Page 2
- RMPR4D1 ;PHX/HNB -DISPLAY/LOOKUP/DIC(W) PURCHASE CARD ;3/1/1996
- +1 ;;3.0;PROSTHETICS;**3**;Feb 09, 1996
- EN ;DISPLAY DATE,PATIENT,ITEM,COST FROM 660
- +1 SET Z=^RMPR(660,+Y,0)
- +2 ;should call getpat instead.
- +3 SET RMPRDFN=$PIECE(Z,U,2)
- SET RMPRNAM=$PIECE(^DPT(RMPRDFN,0),U,1)
- SET RMPRIT=$PIECE(Z,U,6)
- +4 IF RMPRIT'=""
- SET RMPRIT=$PIECE(^RMPR(661,RMPRIT,0),U,1)
- SET RMPRIT=$PIECE(^PRC(441,RMPRIT,0),U,2)
- +5 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")
- +6 SET RMPRCST="$"_$JUSTIFY($FNUMBER($PIECE(Z,U,16),"T",2),8)
- +7 WRITE ?25,$EXTRACT(RMPRNAM,1,18),?45,$EXTRACT(RMPRIT,1,23),?70,RMPRCST
- +8 KILL RMPRDFN,RMPRNAM,RMPRIT,RMPRCST,Z
- QUIT
- EN1 ;DISPLAY DATE,REFERENCE,PATIENT FROM 664
- +1 ;called from en2
- +2 NEW RZ,RZZ
- +3 if $GET(RMPRQT)=1
- QUIT
- +4 IF $GET(DIC)="^RMPR(664,"
- SET RZ=^RMPR(664,+Y,0)
- SET RZZ=$PIECE(RZ,U,7)
- +5 if $PIECE(RZ,U,8)
- WRITE ?49,"Closed"
- if $PIECE(RZ,U,5)
- WRITE ?49,"Cancelled"
- +6 if $GET(^RMPR(664,+Y,4))
- WRITE ?49,"BA:",$PIECE(^(4),U,2)
- +7 IF $GET(RZZ)=""
- IF $PIECE(RZ,U,15)
- IF $DATA(^RMPR(664.2,+$PIECE(RZ,U,15),0))
- WRITE ?40,$PIECE(^(0),U)
- +8 IF $DATA(^RMPR(664,+Y,1,0))
- Begin DoDot:1
- +9 SET RMPRI=0
- +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(^RMPR(661,RMPRI1,0),U,1)
- +13 SET RMPRN=$PIECE(^PRC(441,RMPRIT,0),U,2)
- +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 QUIT
- EN2 ;DISPLAY NAME
- +1 ;used for dic(w) only, file 664
- +2 NEW RZ
- +3 SET RZ=$PIECE(^RMPR(664,+Y,0),U,2)
- IF +RZ
- WRITE ?33,$EXTRACT($PIECE(^DPT(+RZ,0),U,1),1,15)
- GOTO EN1
- +4 QUIT
- EN5 ;Inquire to purchase card transaction
- +1 IF '$DATA(RMPR)
- DO DIV4^RMPRSIT
- if $DATA(X)
- QUIT
- +2 NEW DIC
- +3 SET RMPRQT=1
- +4 ;,DIC("W")="D EN2^RMPR4D1"
- SET DIC="^RMPR(664,"
- SET DIC(0)="AEQMZ"
- +5 KILL IOP
- IF $EXTRACT(IOST)["C"
- GOTO EN6
- +6 SET DIC("S")="I $D(^(4)) I $P(^(0),U,14)=RMPR(""STA"")"
- +7 DO ^DIC
- if Y'>0
- QUIT
- +8 SET RMPRDA=+Y
- +9 SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- GOTO EXIT
- +10 IF $DATA(IO("Q"))
- Begin DoDot:1
- +11 SET ZTSAVE("RMPRDA")=""
- SET ZTSAVE("RMPR(")=""
- +12 SET ZTSAVE("DATE(")=""
- SET ZTSAVE("RMPRSITE")=""
- +13 SET ZTIO=ION
- SET ZTRTN="EN6^RMPRD1"
- SET ZTDESC="Inquire To Purchase Card"
- +14 DO ^%ZTLOAD
- KILL ZTDESC,ZTIO,ZTRTN,ZTSAVE
- End DoDot:1
- GOTO EXIT
- EN6 ;Printinig Purchase Card
- +1 NEW RPO,RPO1
- KILL DR
- +2 SET DA=RMPRDA
- SET DIQ="RPO"
- SET DR=".01:24"
- SET RMPRDA=DA
- +3 DO EN^DIQ1
- +4 SET DR(664.02)=".01:16"
- +5 SET RPO1=0
- +6 FOR
- SET RPO1=$ORDER(^RMPR(664,DA,1,RPO1))
- if RPO1'>0
- QUIT
- Begin DoDot:1
- +7 SET DA(664.02)=RPO1
- +8 DO EN^DIQ1
- End DoDot:1
- +9 ;Display
- +10 USE IO
- +11 IF $Y>1
- WRITE @IOF
- +12 WRITE "Patient: ",RPO(664,RMPRDA,1),?40,"Vendor:",RPO(664,RMPRDA,4)
- +13 WRITE !,"Request Date: ",RPO(664,RMPRDA,.01),?33,"Date Required: ",RPO(664,RMPRDA,20),?69,"Days: ",RPO(664,RMPRDA,21)
- +14 WRITE !,"Form: ",RPO(664,RMPRDA,15),?33,"Initiator: ",$EXTRACT(RPO(664,RMPRDA,10),1,12),?60,"Sta.: ",$EXTRACT(RPO(664,RMPRDA,18),1,11)
- +15 IF $GET(RPO(664,RMPRDA,8))'=""
- Begin DoDot:1
- +16 WRITE !!,"Close Out Date:",RPO(664,RMPRDA,8),?40,"Closed By:",RPO(664,RMPRDA,8.5)
- +17 WRITE !,"Remarks: ",RPO(664,RMPRDA,8.1)
- End DoDot:1
- +18 IF $GET(RPO(664,RMPRDA,12))'=""
- Begin DoDot:1
- +19 WRITE !!,"Shipping Entry: ",RPO(664,RMPRDA,13)
- +20 WRITE ?40,"Shipping Charge: ",RPO(664,RMPRDA,12)
- End DoDot:1
- +21 IF $GET(RPO(664,RMPRDA,3))'=""
- Begin DoDot:1
- +22 WRITE !!,"Canceled Date: ",RPO(664,RMPRDA,3),?40,"Canceled By: ",RPO(664,RMPRDA,3.2)
- +23 WRITE !,"Cancelation Remarks: ",RPO(664,RMPRDA,3.1)
- End DoDot:1
- +24 IF $GET(RPO(664,RMPRDA,22))'=""
- Begin DoDot:1
- +25 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
- +26 WRITE !!,"Obligation #:",RPO(664,RMPRDA,.5)
- +27 WRITE ?35,"C.P.:",RPO(664,RMPRDA,6)
- +28 WRITE !,"Reference: ",RPO(664,RMPRDA,7)
- +29 WRITE ?35,"% Discount: ",RPO(664,RMPRDA,17)
- +30 WRITE ?60,"PSC Category: ",RPO(664,RMPRDA,16)
- +31 ;Item Mult. Display
- +32 SET RD1=0
- FOR
- SET RD1=$ORDER(^RMPR(664,DA,1,RD1))
- if $GET(RD1)'>0
- QUIT
- Begin DoDot:1
- +33 WRITE !!,"Item:",RPO(664.02,RD1,.01)
- +34 WRITE ?34,"Qty:",RPO(664.02,RD1,3)_" "_RPO(664.02,RD1,4)
- +35 WRITE ?60,"Unit Cost :",RPO(664.02,RD1,2)
- +36 WRITE !,?2,"Actual Unit Cost: ",RPO(664.02,RD1,2)
- +37 WRITE ?34,"Source:",RPO(664.02,RD1,11)
- +38 WRITE ?60,"Serial #:",RPO(664.02,RD1,15)
- +39 WRITE !,?2,"Patient Category: ",RPO(664.02,RD1,9),?34,"Type of Transaction: ",RPO(664.02,RD1,9)
- +40 WRITE !,?2,"Special Category: ",RPO(664.02,RD1,10),?34,"Appliance/Repair: ",RPO(664.02,RD1,12)
- +41 WRITE !!,?2,"Item Remarks: ",RPO(664.02,RD1,7)
- End DoDot:1
- +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
