RMPRP55 ;PHX/DWL/HNB-PRINT 10-55 ;3/17/03 13:05
;;3.0;PROSTHETICS;**20,55,77**;Feb 09, 1996
;
; ODJ - patch 55 - 1/29/01 - replace 121 hard coded mail symbol with
; call to site param. extrinsic
; nois AUG-1097-32118
; RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
;
I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EXIT
I $D(RMPRA) G ZIS
EN ;ENTRY POINT FOR REPRINTING A 10-55
D DIV4^RMPRSIT G:$D(X) EXIT
S DIC="^RMPR(664,",DIC(0)="AEMQ",DIC("W")="D EN2^RMPRD1"
S DIC("A")="Select Transaction or Patient Name: "
S DIC("S")="I $D(^RMPR(664,Y,1)) S R1=$O(^RMPR(664,Y,1,0)) I R1 S RX=$P(^(R1,0),U,13) S:$D(^RMPR(660,+RX,0)) RX=$P(^(0),U,13) I RX=1!(RX=10) I '$D(^RMPR(664,""AP"",RMPR(""STA""),Y))"
D ^DIC G:+Y<1 EXIT
S RMPRA=+Y,RMPRACT=1 I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM G EXIT
D PR^RMPR21A I %'>0 G EXIT
S RX=^RMPR(664,RMPRA,0)
ZIS ;
I $P(^RMPR(669.9,RMPRSITE,0),U,5) S IOP="Q;"_$P(^%ZIS(1,$P(^(0),U,5),0),U,1),%ZIS="MQ" D ^%ZIS G:POP EXIT G PT
S %ZIS="MQ" D ^%ZIS G:POP EXIT I $D(IO("Q")) S ZTIO=ION G PT
U IO
EN1 ;ADDRESS DEFINED
W:$E(IOST)["C" @IOF S %X="^RMPR(664,RMPRA,",%Y="R55(" D %XY^%RCR
S Y=DT D DD^%DT S DATE=Y,RMPRTT="" W:$D(RMPRACT) ?30,"****DUPLICATE COPY****" I $P($G(R55(4)),U,8)=1 W ?30,"***WORKING COPY***"
W !!!,?5,"DEPARTMENT OF VETERANS AFFAIRS" W !,?5,RMPR("NAME"),!,?5,RMPR("ADD"),!,?5,RMPR("CITY")
ADD ;ADDRESS INFO
S RMPRUP=0,I=0,RMPRV=$P(^RMPR(664,RMPRA,0),U,4),RMPRV=^PRC(440,RMPRV,0),RMPRST=$P(RMPRV,U,7),RMPRST=$S(RMPRST="":"NO STATE",1:$P(^DIC(5,RMPRST,0),U,2)),RMPRDUZ="",RMPRDUZ=$P(^RMPR(664,RMPRA,0),U,9),RMPRDUZ=$P(^VA(200,RMPRDUZ,0),U,1)
S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2)
S I=$O(^RMPR(664,RMPRA,1,I))
S RMPRI=$P(^RMPR(664,RMPRA,1,I,0),U,1)
S RMPRUP=$O(^RMPR(665,"C",RMPRI,RMPRDFN,RMPRUP))
S:RMPRUP RMPRSN=$P(^RMPR(665,RMPRDFN,5,RMPRUP,0),U,3)
;Should call VADPT not look at global directly
S RMPRNAM=$P(^DPT(RMPRDFN,0),U,1)
S RMPRSSN=$P(^DPT(RMPRDFN,0),U,9)
S RMPRTN=$P(^RMPR(664,RMPRA,0),U,7)
WRITE W !!!!!,?5,$P(RMPRV,U,1),?53,"In Reply Refer to:",?73,$$STA^RMPRUTIL_"-",$$ROU^RMPRUTIL(RMPRSITE),!,?5,$P(RMPRV,U,2),?53,RMPRNAM
W !?5,$P(RMPRV,U,6),", ",RMPRST," ",$P(RMPRV,U,8)
W ?53,$E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,9),!,?53,RMPRTN
W !!,?5,$P(RMPRV,U,1),!!,?5,"With reference to your request of ",?39,$E($P(^RMPR(664,RMPRA,0),U,1),4,5),"/",$E($P(^RMPR(664,RMPRA,0),U,1),6,7),"/",$E($P(^RMPR(664,RMPRA,0),U,1),2,3),", authority is granted to repair "
W !,?5,"the appliance described below for the above-named veteran."
DESC ;ITEM,DES,COST,QTY
S $P(LINE,".",75)=""
W !!,?5,LINE,!,?23,"DESCRIPTION OF APPLIANCE OR REPAIR",!,?63,"Unit",?73,"Total",!,?5,"Item",?11,"Name",?32,"Serial Number",?55,"Qty",?63,"Price",?73,"Cost",!,?5,LINE
S I=0,RMPRTO=0 F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)),RMPRDFN="" G COST:I'>0 D LIST
COST S X=RMPRTO,X2="2$",X3=9 D COMMA^%DTC
W !!,?5,"The total cost, not including mailing cost, will not exceed ",?RR+1,X,!!,?5,"When repairs are completed, please attach the original of this letter to"
W !,?5,"the original copy of your invoice covering repair charges. Your invoice,",!,?5,"in original and one copy should then be forwarded to this office for"
W !?5,"payment.",!!?5,"Please retain the duplicate copy of this letter for your files."
W !!,?5,"Sincerely,",!!!!,?5,RMPR("SIG"),", Chief",!,?5,RMPR("SBT")
END S L=19-RMPRTT F I=1:1:L W !
W ?5,"Initiator: ",RMPRDUZ,?45,"REF: ",RMPRA,?64,"ADP FORM 10-55" D:$D(RMPRPRIV) ^RMPRP23
EXIT K RMPRACT,ZTSK,RX,RMPRI,RMPRTN,RMPRDS,RMPRQT,RMPRCT,RMPRTO,RMPRUP,RR,I,DATE,DIC,RG,L,LINE,RMPRA,RMPRDFN,RMPRIS,RMPRNAM,RMPRNM,RMPRSN,RMPRSSN,RMPRST,RMPRTT,RMPRPRIV,RMPRCC,RXT,RX1
K RMPRV,X2,X3,RMPRDUZ,RMPRI1,RMPRIT,RMPRN,VA,VAEL,RZZZ,VAERR,Y,RMPRPRIV,RTX D ^%ZISC Q
LIST S RR=^RMPR(664,RMPRA,1,I,0),RMPRIS=$P(RR,U,5),RMPRIS=$P(^PRCD(420.5,RMPRIS,0),U,1),RMPRI=$P(RR,U,1),RMPRI=$P(^RMPR(661,RMPRI,0),U,1),RMPRI=^PRC(441,RMPRI,0),RMPRNM=$P(RMPRI,U,2),RMPRI=$P(RMPRI,U,1)
S RMPRCT=$P(RR,U,3),RMPRQT=$P(RR,U,4),RMPRTO=(RMPRCT*RMPRQT)+RMPRTO,RMPRDS=$P(RR,U,2),X=RMPRCT,X2="2$",X3=9 D COMMA^%DTC S RR=$L(X),RR=79-RR W !,?5,RMPRI,?11,$E(RMPRNM,1,18),?32,$G(RMPRSN),?56,RMPRQT,?59,X,!,?11,RMPRDS
I $P(^RMPR(664,RMPRA,0),U,10)!($P(^(0),U,11)) S RR=$S($P(^(0),U,11):$P(^(0),U,11),1:$P(^(0),U,10)) I RR S X=RR,X2="2$",X3=9 D COMMA^%DTC S RR=$L(X),RR=79-RR W !,?32,"Shipping Charge: ",?59,X,!
I $D(R55(1,1,1,0)) F RTX=0:0 S RTX=$O(R55(1,1,1,RTX)) Q:RTX'>0 W !,?5,R55(1,1,1,RTX,0)
CNTER S RMPRTT=(RMPRTT+1) K R55 Q
PT F RG="DT","RMPRSITE","RMPRA","RMPRUP","RMPR(" S ZTSAVE(RG)="" S:$D(RMPRACT) ZTSAVE("RMPRACT")="" S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")=""
I $D(IO("Q")) S ZTRTN="EN1^RMPRP55",ZTDTH=$H,ZTDESC="PROSTHETICS PRINT OF 10-55",ZTIO=ION D ^%ZTLOAD
W !,$S($D(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST DID NOT QUEUE!>")
D HOME^%ZIS G EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRP55 4920 printed Oct 16, 2024@18:36:11 Page 2
RMPRP55 ;PHX/DWL/HNB-PRINT 10-55 ;3/17/03 13:05
+1 ;;3.0;PROSTHETICS;**20,55,77**;Feb 09, 1996
+2 ;
+3 ; ODJ - patch 55 - 1/29/01 - replace 121 hard coded mail symbol with
+4 ; call to site param. extrinsic
+5 ; nois AUG-1097-32118
+6 ; RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
+7 ;
+8 IF '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+9 IF $DATA(RMPRA)
GOTO ZIS
EN ;ENTRY POINT FOR REPRINTING A 10-55
+1 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+2 SET DIC="^RMPR(664,"
SET DIC(0)="AEMQ"
SET DIC("W")="D EN2^RMPRD1"
+3 SET DIC("A")="Select Transaction or Patient Name: "
+4 SET DIC("S")="I $D(^RMPR(664,Y,1)) S R1=$O(^RMPR(664,Y,1,0)) I R1 S RX=$P(^(R1,0),U,13) S:$D(^RMPR(660,+RX,0)) RX=$P(^(0),U,13) I RX=1!(RX=10) I '$D(^RMPR(664,""AP"",RMPR(""STA""),Y))"
+5 DO ^DIC
if +Y<1
GOTO EXIT
+6 SET RMPRA=+Y
SET RMPRACT=1
IF $PIECE(^RMPR(664,+Y,0),U,5)
DO M2^RMPRM
GOTO EXIT
+7 DO PR^RMPR21A
IF %'>0
GOTO EXIT
+8 SET RX=^RMPR(664,RMPRA,0)
ZIS ;
+1 IF $PIECE(^RMPR(669.9,RMPRSITE,0),U,5)
SET IOP="Q;"_$PIECE(^%ZIS(1,$PIECE(^(0),U,5),0),U,1)
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
GOTO PT
+2 SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTIO=ION
GOTO PT
+3 USE IO
EN1 ;ADDRESS DEFINED
+1 if $EXTRACT(IOST)["C"
WRITE @IOF
SET %X="^RMPR(664,RMPRA,"
SET %Y="R55("
DO %XY^%RCR
+2 SET Y=DT
DO DD^%DT
SET DATE=Y
SET RMPRTT=""
if $DATA(RMPRACT)
WRITE ?30,"****DUPLICATE COPY****"
IF $PIECE($GET(R55(4)),U,8)=1
WRITE ?30,"***WORKING COPY***"
+3 WRITE !!!,?5,"DEPARTMENT OF VETERANS AFFAIRS"
WRITE !,?5,RMPR("NAME"),!,?5,RMPR("ADD"),!,?5,RMPR("CITY")
ADD ;ADDRESS INFO
+1 SET RMPRUP=0
SET I=0
SET RMPRV=$PIECE(^RMPR(664,RMPRA,0),U,4)
SET RMPRV=^PRC(440,RMPRV,0)
SET RMPRST=$PIECE(RMPRV,U,7)
SET RMPRST=$SELECT(RMPRST="":"NO STATE",1:$PIECE(^DIC(5,RMPRST,0),U,2))
SET RMPRDUZ=""
SET RMPRDUZ=$PIECE(^RMPR(664,RMPRA,0),U,9)
SET RMPRDUZ=$PIECE(^VA(200,RMPRDUZ,0),U,1)
+2 SET RMPRDFN=$PIECE(^RMPR(664,RMPRA,0),U,2)
+3 SET I=$ORDER(^RMPR(664,RMPRA,1,I))
+4 SET RMPRI=$PIECE(^RMPR(664,RMPRA,1,I,0),U,1)
+5 SET RMPRUP=$ORDER(^RMPR(665,"C",RMPRI,RMPRDFN,RMPRUP))
+6 if RMPRUP
SET RMPRSN=$PIECE(^RMPR(665,RMPRDFN,5,RMPRUP,0),U,3)
+7 ;Should call VADPT not look at global directly
+8 SET RMPRNAM=$PIECE(^DPT(RMPRDFN,0),U,1)
+9 SET RMPRSSN=$PIECE(^DPT(RMPRDFN,0),U,9)
+10 SET RMPRTN=$PIECE(^RMPR(664,RMPRA,0),U,7)
WRITE WRITE !!!!!,?5,$PIECE(RMPRV,U,1),?53,"In Reply Refer to:",?73,$$STA^RMPRUTIL_"-",$$ROU^RMPRUTIL(RMPRSITE),!,?5,$PIECE(RMPRV,U,2),?53,RMPRNAM
+1 WRITE !?5,$PIECE(RMPRV,U,6),", ",RMPRST," ",$PIECE(RMPRV,U,8)
+2 WRITE ?53,$EXTRACT(RMPRSSN,1,3)_"-"_$EXTRACT(RMPRSSN,4,5)_"-"_$EXTRACT(RMPRSSN,6,9),!,?53,RMPRTN
+3 WRITE !!,?5,$PIECE(RMPRV,U,1),!!,?5,"With reference to your request of ",?39,$EXTRACT($PIECE(^RMPR(664,RMPRA,0),U,1),4,5),"/",$EXTRACT($PIECE(^RMPR(664,RMPRA,0),U,1),6,7),"/",$EXTRACT($PIECE(^RMPR(664,RMPRA,0),U,1),2,3),", authority is granted
to repair "
+4 WRITE !,?5,"the appliance described below for the above-named veteran."
DESC ;ITEM,DES,COST,QTY
+1 SET $PIECE(LINE,".",75)=""
+2 WRITE !!,?5,LINE,!,?23,"DESCRIPTION OF APPLIANCE OR REPAIR",!,?63,"Unit",?73,"Total",!,?5,"Item",?11,"Name",?32,"Serial Number",?55,"Qty",?63,"Price",?73,"Cost",!,?5,LINE
+3 SET I=0
SET RMPRTO=0
FOR I=0:0
SET I=$ORDER(^RMPR(664,RMPRA,1,I))
SET RMPRDFN=""
if I'>0
GOTO COST
DO LIST
COST SET X=RMPRTO
SET X2="2$"
SET X3=9
DO COMMA^%DTC
+1 WRITE !!,?5,"The total cost, not including mailing cost, will not exceed ",?RR+1,X,!!,?5,"When repairs are completed, please attach the original of this letter to"
+2 WRITE !,?5,"the original copy of your invoice covering repair charges. Your invoice,",!,?5,"in original and one copy should then be forwarded to this office for"
+3 WRITE !?5,"payment.",!!?5,"Please retain the duplicate copy of this letter for your files."
+4 WRITE !!,?5,"Sincerely,",!!!!,?5,RMPR("SIG"),", Chief",!,?5,RMPR("SBT")
END SET L=19-RMPRTT
FOR I=1:1:L
WRITE !
+1 WRITE ?5,"Initiator: ",RMPRDUZ,?45,"REF: ",RMPRA,?64,"ADP FORM 10-55"
if $DATA(RMPRPRIV)
DO ^RMPRP23
EXIT KILL RMPRACT,ZTSK,RX,RMPRI,RMPRTN,RMPRDS,RMPRQT,RMPRCT,RMPRTO,RMPRUP,RR,I,DATE,DIC,RG,L,LINE,RMPRA,RMPRDFN,RMPRIS,RMPRNAM,RMPRNM,RMPRSN,RMPRSSN,RMPRST,RMPRTT,RMPRPRIV,RMPRCC,RXT,RX1
+1 KILL RMPRV,X2,X3,RMPRDUZ,RMPRI1,RMPRIT,RMPRN,VA,VAEL,RZZZ,VAERR,Y,RMPRPRIV,RTX
DO ^%ZISC
QUIT
LIST SET RR=^RMPR(664,RMPRA,1,I,0)
SET RMPRIS=$PIECE(RR,U,5)
SET RMPRIS=$PIECE(^PRCD(420.5,RMPRIS,0),U,1)
SET RMPRI=$PIECE(RR,U,1)
SET RMPRI=$PIECE(^RMPR(661,RMPRI,0),U,1)
SET RMPRI=^PRC(441,RMPRI,0)
SET RMPRNM=$PIECE(RMPRI,U,2)
SET RMPRI=$PIECE(RMPRI,U,1)
+1 SET RMPRCT=$PIECE(RR,U,3)
SET RMPRQT=$PIECE(RR,U,4)
SET RMPRTO=(RMPRCT*RMPRQT)+RMPRTO
SET RMPRDS=$PIECE(RR,U,2)
SET X=RMPRCT
SET X2="2$"
SET X3=9
DO COMMA^%DTC
SET RR=$LENGTH(X)
SET RR=79-RR
WRITE !,?5,RMPRI,?11,$EXTRACT(RMPRNM,1,18),?32,$GET(RMPRSN),?56,RMPRQT,?59,X,!,?11,RMPRDS
+2 IF $PIECE(^RMPR(664,RMPRA,0),U,10)!($PIECE(^(0),U,11))
SET RR=$SELECT($PIECE(^(0),U,11):$PIECE(^(0),U,11),1:$PIECE(^(0),U,10))
IF RR
SET X=RR
SET X2="2$"
SET X3=9
DO COMMA^%DTC
SET RR=$LENGTH(X)
SET RR=79-RR
WRITE !,?32,"Shipping Charge: ",?59,X,!
+3 IF $DATA(R55(1,1,1,0))
FOR RTX=0:0
SET RTX=$ORDER(R55(1,1,1,RTX))
if RTX'>0
QUIT
WRITE !,?5,R55(1,1,1,RTX,0)
CNTER SET RMPRTT=(RMPRTT+1)
KILL R55
QUIT
PT FOR RG="DT","RMPRSITE","RMPRA","RMPRUP","RMPR("
SET ZTSAVE(RG)=""
if $DATA(RMPRACT)
SET ZTSAVE("RMPRACT")=""
if $DATA(RMPRPRIV)
SET ZTSAVE("RMPRPRIV")=""
+1 IF $DATA(IO("Q"))
SET ZTRTN="EN1^RMPRP55"
SET ZTDTH=$HOROLOG
SET ZTDESC="PROSTHETICS PRINT OF 10-55"
SET ZTIO=ION
DO ^%ZTLOAD
+2 WRITE !,$SELECT($DATA(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST DID NOT QUEUE!>")
+3 DO HOME^%ZIS
GOTO EXIT
