RMPR29RG ;HIOFO/SPS-OWL WINDOWS PRINTER [ 12/01/05 5:39 AM ]
;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25
;get basic info, system variables
;WINDOW FAX/PRINT 2529-3 PASS RMPRA
;REQUIRED VARIABLES: RMPRDA - ENTRY NUMBER IN FILE 664.1
; RMPRSITE - SITE OFSTATION PROCESSING 2529-3
; RMPRPTR - "WINDOWS"
IN(RMPRA,RMPRSITE,RMPRPTR) ;
;TEST ENTRY
D IN2
Q
K CNT,I,K,L,LCN,LNM,LSSN,LSTN,R643,RDO,RDI,RHDA,RI,RIDA,RIDES,RMPR,RMPR0
K RMPR21,RMPRAOF,RMPRCDT,RMPRCSZ,RMPRD,RMPRDA,RMPREXT,RMPRINM,RMPRINSN
K RMPRL,RMPRODT,RMPRRDT,RMPRROF,RMPRS,RMPRSOP,RMPRSTN,RMPGIP,RPHCPC
K RD0,RD1,RPGIP,RPSAITEM,RPSALOC,SPACE,VA,VADM,VAEL,VAPA
PRT(RESULTS,RMPRA,RMPRSITE,RMPRPTR) ;GUI ENTRY
IN2 I RMPRPTR'="WINDOWS" S RMPRDA=RMPRA G PRT^RMPR29R
K ^TMP($J,"RMPRT"),RESULTS
S DIC=4,DIC(0)="QZN",X=$P(^RMPR(664.1,RMPRA,0),U,15)
D ^DIC G:+Y'>0 EXIT
N RC
S RMPRINS=+Y,RC=0,RMPRINSN=$P(^DIC(4,RMPRINS,99),U)
S RMPRST=$S($D(^DIC(5,+$P(Y(0),U,2),0)):$P(^(0),U),1:"")
S (RMPRAD(1),RMPRAD(2),RMPRCT,RMPR9P)=""
I $D(^DIC(4,RMPRINS,1)) S RMPRAD(1)=$P(^(1),U,1),RMPRAD(2)=$P(^(1),U,2),RMPRCT=$P(^(1),U,3),RMPR9P=$P(^(1),U,4)
S DFN=$P(^RMPR(664.1,RMPRA,0),U,2) D ALL^VADPT
;
I $P(^RMPR(664.1,RMPRA,0),U,11)="N" N RMPRFCTR D
.;national footwear center address in RMPRFCTR array used in print
.;template RMPR 25293
.S RMPRFCTR(1)="179TH ST & LINDEN BLVD."
.S RMPRFCTR(2)="ST. ALBANS, NY 11425"
;
S RMPR0=^RMPR(664.1,RMPRA,0)
S RMPRRDT=$$EXTERNAL^DILFD(664.1,17,,$P(RMPR0,U,18))
S RMPRCDT=$$EXTERNAL^DILFD(664.1,23,,$P(RMPR0,U,26))
S RMPRROF=$$EXTERNAL^DILFD(664.1,13,,$P(RMPR0,U,5))
S RMPRAOF=$$EXTERNAL^DILFD(664.1,14,,$P(RMPR0,U,7))
S RMPRODT=$$EXTERNAL^DILFD(664.1,.01,,$P(RMPR0,U,1))
S (RMPRL,RMPRD,RMPRS)="",$P(RMPRL,"_",81)="",$P(RMPRD,"-",81)=""
S ^TMP($J,"RMPRT",0)=" REQUEST AND RECEIPT FOR PROSTHETIC APPLIANCES OR SERVICES "
S ^TMP($J,"RMPRT",1)=RMPRL
S ^TMP($J,"RMPRT",2)=" SECTION I"
S ^TMP($J,"RMPRT",3)=RMPRD
S RMPRSOP=$$EXTERNAL^DILFD(664.1,2,,$P(RMPR0,U,11))
S ^TMP($J,"RMPRT",4)="TO: | "_RMPRSOP
S L=$L(RMPRSOP),L=L+38,$P(RMPRS," ",80-L)=""
S (L,RMPRS)="",L=$L(RMPRSOP),L=L+6,$P(RMPRS," ",(45-L))=""
S ^TMP($J,"RMPRT",4)=^TMP($J,"RMPRT",4)_RMPRS_"1. VETERANS NAME (LAST,FIRST,M.I.)"
S ^TMP($J,"RMPRT",5)=" "_$$EXTERNAL^DILFD(664.1,.11,,$P(RMPR0,U,15))
S (L,RMPRS)="",L=$L($$EXTERNAL^DILFD(664.1,.11,,$P(RMPR0,U,15))),L=L+6,$P(RMPRS," ",(49-L))=""
S ^TMP($J,"RMPRT",5)=^TMP($J,"RMPRT",5)_RMPRS_VADM(1)
I RMPRAD(1)'="" S ^TMP($J,"RMPRT",6)=" "_$E(RMPRAD(1),1,30)
I RMPRAD(2)'="" S ^TMP($J,"RMPRT",7)=" "_$E(RMPRAD(2),1,30)
S ^TMP($J,"RMPRT",8)=" "_RMPRCT_", "_RMPRST_" "_RMPR9P
S ^TMP($J,"RMPRT",9)=RMPRD
S ^TMP($J,"RMPRT",10)="2. VETERANS ADDRESS 3. CLAIM NO. 4. SSN 5. STATION NO."
S LNM=$L(VADM(1)),LCN=$L(VAEL(7)),LSSN=$L(VA("PID")),LSTN=$L(RMPRINSN)
S (L,RMPRS)="",L=$L(VADM(1)),L=L+3,$P(RMPRS," ",(36-L))=""
S ^TMP($J,"RMPRT",11)=" "_VADM(1)_RMPRS_VAEL(7)
S (L,RMPRS)="",L=L+$L(VAEL(7)),$P(RMPRS," ",(17-L))=""
S ^TMP($J,"RMPRT",11)=^TMP($J,"RMPRT",11)_RMPRS_VA("PID")_" "_RMPRINSN
S ^TMP($J,"RMPRT",12)=" "_VAPA(1)
I VAPA(2)'="" S ^TMP($J,"RMPRT",13)=" "_VAPA(2)
I VAPA(3)'="" S ^TMP($J,"RMPRT",14)=" "_VAPA(3)
S RMPRCSZ=$P(VAPA(4),U,1)_","_$P(VAPA(5),U,2)_" "_VAPA(6)
S L=$L(RMPRCSZ),L=50-L,SPACE="",$P(SPACE," ",L)=""
S (L,RMPRS)="",L=L+$L(RMPRCSZ),$P(RMPRS," ",(50-L))=""
S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
S ^TMP($J,"RMPRT",CNT+1)=" "_RMPRCSZ_RMPRS_"VETERANS PHONE: "_VAPA(8)
S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
S ^TMP($J,"RMPRT",CNT+1)=RMPRD
S ^TMP($J,"RMPRT",CNT+2)="6. AUTHORITY FOR ISSUANCE 7. ELIGIBILITY STATUS 8. DATE REQUIRED"
S ^TMP($J,"RMPRT",CNT+3)=" CFR 17.115 "_$S($P(VAEL(3),U,1)=1:"SC",1:"NSC")
;S ^TMP($J,"RMPRT",CNT+4)=" 9. DISABILITY CODE:"
S ^TMP($J,"RMPRT",CNT+5)=RMPRD
S ^TMP($J,"RMPRT",CNT+6)=" 10.TYPES AND QUANTITIES OF APPLIANCES AND/OR SERVICES REQUESTED"
S ^TMP($J,"RMPRT",CNT+7)=RMPRD
S ^TMP($J,"RMPRT",CNT+8)=" *UNIT *TOTAL"
S ^TMP($J,"RMPRT",CNT+9)=" ITEM # NOMENCLATURE QTY UNIT COST COST"
S ^TMP($J,"RMPRT",CNT+10)=RMPRD
; Item Multiple
S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
S RI=""
F S RI=$O(^RMPR(664.1,RMPRA,2,RI)) Q:RI="" D
.Q:'$D(^RMPR(664.1,RMPRA,2,RI,0))
.S CNT=CNT+1
.S RMPR21=$G(^RMPR(664.1,RMPRA,2,RI,0))
.I RMPR21="" S RESULTS="1^No item multiple found"
.F I=1:1:11 S RMPR21(I)=""
.S RMPR21(1)=$P(RMPR21,U,1),RMPR21(2)=$P(RMPR21,U,2)
.S RMPR21(3)=$$EXTERNAL^DILFD(664.16,3,,$P(RMPR21,U,3))
.S RMPRINM=$$EXTERNAL^DILFD(664.16,.01,,$P(RMPR21,U)),RMPRINM=$E(RMPRINM,1,24)
.S RMPR21(4)=$S($P(RMPR21,U,4)>0:$P(RMPR21,U,4),1:"0.00")
.S RMPR21(11)=$S($P(RMPR21,U,11)>0:$P(RMPR21,U,11),1:"0.00")
.S (L,RMPRS)="",L=L+6,L=L+$L(RMPR21(1)),$P(RMPRS," ",(15-L))=""
.S ^TMP($J,"RMPRT",CNT)=" "_RMPR21(1)_RMPRS_RMPRINM
.S (L,RMPRS)="",L=L+$L(RMPRINM),$P(RMPRS," ",(29-L))=""
.S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(2)
.S (L,RMPRS)="",L=L+$L(RMPR21(2)),$P(RMPRS," ",(14-L))=""
.S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(3)
.S (L,RMPRS)="",L=L+$L(RMPR21(3)),$P(RMPRS," ",(8-L))=""
.S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(4)_RMPRS_RMPR21(11)
.S RMPREXT=0
.F S RMPREXT=$O(^RMPR(664.1,RMPRA,2,RI,1,RMPREXT)) Q:RMPREXT="" D
..S CNT=CNT+1
..S ^TMP($J,"RMPRT",CNT)=^RMPR(664.1,RMPRA,2,RI,1,RMPREXT,0)
.D HCP
S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
S ^TMP($J,"RMPRT",CNT+1)=RMPRD
S ^TMP($J,"RMPRT",CNT+2)="11. PROCUREMENT SOURCE: "_RMPRSOP
S ^TMP($J,"RMPRT",CNT+3)=RMPRD
S ^TMP($J,"RMPRT",CNT+4)="12. SIGNATURE AND TITLE OF 13. DATE 14. SIGNATURE AND TITLE OF 15. DATE"
S ^TMP($J,"RMPRT",CNT+5)=" REQUESTING OFFICIAL "_RMPRRDT_" APPROVING OFFICIAL"
S (L,RMPRS)="",L=+$L(RMPRROF),$P(RMPRS," ",(46-L))=""
S ^TMP($J,"RMPRT",CNT+6)=" "_RMPRROF_RMPRS_RMPRAOF
S ^TMP($J,"RMPRT",CNT+7)=RMPRD
S ^TMP($J,"RMPRT",CNT+8)=" SECTION III"
S ^TMP($J,"RMPRT",CNT+9)=RMPRL
S ^TMP($J,"RMPRT",CNT+10)="16. ORDER NUMBER 17. DATE OF ORDER 18. DATE ITEM RECIEVED"
S (L,RMPRS)="",L=$L($P(RMPR0,U,13)),$P(RMPRS," ",(30-L))=""
S ^TMP($J,"RMPRT",CNT+11)=" "_$P(RMPR0,U,13)_RMPRS_RMPRODT
S ^TMP($J,"RMPRT",CNT+12)=RMPRD
S ^TMP($J,"RMPRT",CNT+13)="19. DATE DELIVERED 20. SIGNATURE OF INSPECTING OFFICIAL"
S ^TMP($J,"RMPRT",CNT+14)=""
S ^TMP($J,"RMPRT",CNT+15)=RMPRD
S ^TMP($J,"RMPRT",CNT+16)="21. CERTIFICATE OF RECEIPT OR DELIVERY (Check One)"
S ^TMP($J,"RMPRT",CNT+17)=RMPRD
S ^TMP($J,"RMPRT",CNT+18)="[ ] I certify that I have received the items listed above"
S ^TMP($J,"RMPRT",CNT+19)="[ ] I certify that the above item(s) have been sent to"
S ^TMP($J,"RMPRT",CNT+20)=" the Veteran or the requesting field station"
S ^TMP($J,"RMPRT",CNT+21)=RMPRD
S ^TMP($J,"RMPRT",CNT+22)="22. SIGNATURE OF VETERAN OR VA OFFICIAL"
S ^TMP($J,"RMPRT",CNT+23)=""
S ^TMP($J,"RMPRT",CNT+24)=RMPRD
S ^TMP($J,"RMPRT",CNT+25)="23 SIGNATURE OF DESIGNATED EMPLOYEE 24. DATE 25. STATION NO."
S RMPRSTN="" I $D(RMPR("STA")) S RMPRSTN=$P($G(^DIC(4,+RMPR("STA"),99)),U)
S ^TMP($J,"RMPRT",CNT+26)=" "_RMPRCDT_" "_RMPRSTN
S ^TMP($J,"RMPRT",CNT+27)=RMPRD
S ^TMP($J,"RMPRT",CNT+28)="ADP FORM 2529-3"
M RESULTS=^TMP($J,"RMPRT")
G EXIT
Q
HCP ;print HCPCS and GIP or Pros Inventory in -3.
Q:RI'>0
S RD0=RMPRA,RD1=RI
Q:'$D(^RMPR(664.1,RD0,2,RD1,0))
S R643=$G(^RMPR(664.1,RD0,2,RD1,3))
S RPSAITEM=$P(R643,U,3),RPSALOC=$P(R643,U,4)
S RPHCPC=$P($G(^RMPR(664.1,RD0,2,RD1,2)),U,1)
Q:'$G(RPHCPC)
Q:'$D(^RMPR(661.1,RPHCPC,0))
S RPGIP=$P($G(^RMPR(664.1,RD0,2,RD1,0)),U,13)
S ^TMP($J,"RMPRT",CNT+1)=" HCPCS: "_$P(^RMPR(661.1,RPHCPC,0),U,1)
I $G(RPSALOC),RPSAITEM'="",$D(^RMPR(661.3,RPSALOC,0)) D
.S RHDA=$O(^RMPR(661.3,RPSALOC,1,"B",RPHCPC,0)) Q:'$G(RHDA)
.S RIDA=$O(^RMPR(661.3,RPSALOC,1,RHDA,1,"B",RPSAITEM,0))
.S RIDES=$P($G(^RMPR(661.3,RPSALOC,1,RHDA,1,RIDA,0)),U,8)
.S ^TMP($J,"RMPRT",CNT+1)=^TMP($J,"RMPRT",CNT+1)_" RIDES"
I $G(RPSALOC) S ^TMP($J,"RMPRT",CNT+2)="*** Pros Inventory *** Location: "
I $G(RPSALOC) S:$D(^RMPR(661.3,RPSALOC,0)) ^TMP($J,"RMPRT",CNT+2)=^TMP($J,"RMPRT",CNT+2)_$P(^RMPR(661.3,RPSALOC,0),U,1)
I '$G(RPSALOC),$G(RPGIP) S ^TMP($J,"RMPRT",CNT+2)=" *** GIP ***"
I '$G(RPSALOC),'$G(RPGIP) S ^TMP($J,"RMPRT",CNT+2)=" *** OTHER ***"
Q
EXIT ;common exit point
K RMPRA,RMPRSITE,RMPRPTR,RMPRINS,RMPRST,RMPRAD,DIC,DFN
K RA,RB,RFL,RMPRCT,RMPRI,RMPRSC,RMPRWO,RMPR9P,SRC,TO,X,Y
D KVAR^VADPT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29RG 9016 printed Dec 13, 2024@02:32:26 Page 2
RMPR29RG ;HIOFO/SPS-OWL WINDOWS PRINTER [ 12/01/05 5:39 AM ]
+1 ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25
+2 ;get basic info, system variables
+3 ;WINDOW FAX/PRINT 2529-3 PASS RMPRA
+4 ;REQUIRED VARIABLES: RMPRDA - ENTRY NUMBER IN FILE 664.1
+5 ; RMPRSITE - SITE OFSTATION PROCESSING 2529-3
+6 ; RMPRPTR - "WINDOWS"
IN(RMPRA,RMPRSITE,RMPRPTR) ;
+1 ;TEST ENTRY
+2 DO IN2
+3 QUIT
+4 KILL CNT,I,K,L,LCN,LNM,LSSN,LSTN,R643,RDO,RDI,RHDA,RI,RIDA,RIDES,RMPR,RMPR0
+5 KILL RMPR21,RMPRAOF,RMPRCDT,RMPRCSZ,RMPRD,RMPRDA,RMPREXT,RMPRINM,RMPRINSN
+6 KILL RMPRL,RMPRODT,RMPRRDT,RMPRROF,RMPRS,RMPRSOP,RMPRSTN,RMPGIP,RPHCPC
+7 KILL RD0,RD1,RPGIP,RPSAITEM,RPSALOC,SPACE,VA,VADM,VAEL,VAPA
PRT(RESULTS,RMPRA,RMPRSITE,RMPRPTR) ;GUI ENTRY
IN2 IF RMPRPTR'="WINDOWS"
SET RMPRDA=RMPRA
GOTO PRT^RMPR29R
+1 KILL ^TMP($JOB,"RMPRT"),RESULTS
+2 SET DIC=4
SET DIC(0)="QZN"
SET X=$PIECE(^RMPR(664.1,RMPRA,0),U,15)
+3 DO ^DIC
if +Y'>0
GOTO EXIT
+4 NEW RC
+5 SET RMPRINS=+Y
SET RC=0
SET RMPRINSN=$PIECE(^DIC(4,RMPRINS,99),U)
+6 SET RMPRST=$SELECT($DATA(^DIC(5,+$PIECE(Y(0),U,2),0)):$PIECE(^(0),U),1:"")
+7 SET (RMPRAD(1),RMPRAD(2),RMPRCT,RMPR9P)=""
+8 IF $DATA(^DIC(4,RMPRINS,1))
SET RMPRAD(1)=$PIECE(^(1),U,1)
SET RMPRAD(2)=$PIECE(^(1),U,2)
SET RMPRCT=$PIECE(^(1),U,3)
SET RMPR9P=$PIECE(^(1),U,4)
+9 SET DFN=$PIECE(^RMPR(664.1,RMPRA,0),U,2)
DO ALL^VADPT
+10 ;
+11 IF $PIECE(^RMPR(664.1,RMPRA,0),U,11)="N"
NEW RMPRFCTR
Begin DoDot:1
+12 ;national footwear center address in RMPRFCTR array used in print
+13 ;template RMPR 25293
+14 SET RMPRFCTR(1)="179TH ST & LINDEN BLVD."
+15 SET RMPRFCTR(2)="ST. ALBANS, NY 11425"
End DoDot:1
+16 ;
+17 SET RMPR0=^RMPR(664.1,RMPRA,0)
+18 SET RMPRRDT=$$EXTERNAL^DILFD(664.1,17,,$PIECE(RMPR0,U,18))
+19 SET RMPRCDT=$$EXTERNAL^DILFD(664.1,23,,$PIECE(RMPR0,U,26))
+20 SET RMPRROF=$$EXTERNAL^DILFD(664.1,13,,$PIECE(RMPR0,U,5))
+21 SET RMPRAOF=$$EXTERNAL^DILFD(664.1,14,,$PIECE(RMPR0,U,7))
+22 SET RMPRODT=$$EXTERNAL^DILFD(664.1,.01,,$PIECE(RMPR0,U,1))
+23 SET (RMPRL,RMPRD,RMPRS)=""
SET $PIECE(RMPRL,"_",81)=""
SET $PIECE(RMPRD,"-",81)=""
+24 SET ^TMP($JOB,"RMPRT",0)=" REQUEST AND RECEIPT FOR PROSTHETIC APPLIANCES OR SERVICES "
+25 SET ^TMP($JOB,"RMPRT",1)=RMPRL
+26 SET ^TMP($JOB,"RMPRT",2)=" SECTION I"
+27 SET ^TMP($JOB,"RMPRT",3)=RMPRD
+28 SET RMPRSOP=$$EXTERNAL^DILFD(664.1,2,,$PIECE(RMPR0,U,11))
+29 SET ^TMP($JOB,"RMPRT",4)="TO: | "_RMPRSOP
+30 SET L=$LENGTH(RMPRSOP)
SET L=L+38
SET $PIECE(RMPRS," ",80-L)=""
+31 SET (L,RMPRS)=""
SET L=$LENGTH(RMPRSOP)
SET L=L+6
SET $PIECE(RMPRS," ",(45-L))=""
+32 SET ^TMP($JOB,"RMPRT",4)=^TMP($JOB,"RMPRT",4)_RMPRS_"1. VETERANS NAME (LAST,FIRST,M.I.)"
+33 SET ^TMP($JOB,"RMPRT",5)=" "_$$EXTERNAL^DILFD(664.1,.11,,$PIECE(RMPR0,U,15))
+34 SET (L,RMPRS)=""
SET L=$LENGTH($$EXTERNAL^DILFD(664.1,.11,,$PIECE(RMPR0,U,15)))
SET L=L+6
SET $PIECE(RMPRS," ",(49-L))=""
+35 SET ^TMP($JOB,"RMPRT",5)=^TMP($JOB,"RMPRT",5)_RMPRS_VADM(1)
+36 IF RMPRAD(1)'=""
SET ^TMP($JOB,"RMPRT",6)=" "_$EXTRACT(RMPRAD(1),1,30)
+37 IF RMPRAD(2)'=""
SET ^TMP($JOB,"RMPRT",7)=" "_$EXTRACT(RMPRAD(2),1,30)
+38 SET ^TMP($JOB,"RMPRT",8)=" "_RMPRCT_", "_RMPRST_" "_RMPR9P
+39 SET ^TMP($JOB,"RMPRT",9)=RMPRD
+40 SET ^TMP($JOB,"RMPRT",10)="2. VETERANS ADDRESS 3. CLAIM NO. 4. SSN 5. STATION NO."
+41 SET LNM=$LENGTH(VADM(1))
SET LCN=$LENGTH(VAEL(7))
SET LSSN=$LENGTH(VA("PID"))
SET LSTN=$LENGTH(RMPRINSN)
+42 SET (L,RMPRS)=""
SET L=$LENGTH(VADM(1))
SET L=L+3
SET $PIECE(RMPRS," ",(36-L))=""
+43 SET ^TMP($JOB,"RMPRT",11)=" "_VADM(1)_RMPRS_VAEL(7)
+44 SET (L,RMPRS)=""
SET L=L+$LENGTH(VAEL(7))
SET $PIECE(RMPRS," ",(17-L))=""
+45 SET ^TMP($JOB,"RMPRT",11)=^TMP($JOB,"RMPRT",11)_RMPRS_VA("PID")_" "_RMPRINSN
+46 SET ^TMP($JOB,"RMPRT",12)=" "_VAPA(1)
+47 IF VAPA(2)'=""
SET ^TMP($JOB,"RMPRT",13)=" "_VAPA(2)
+48 IF VAPA(3)'=""
SET ^TMP($JOB,"RMPRT",14)=" "_VAPA(3)
+49 SET RMPRCSZ=$PIECE(VAPA(4),U,1)_","_$PIECE(VAPA(5),U,2)_" "_VAPA(6)
+50 SET L=$LENGTH(RMPRCSZ)
SET L=50-L
SET SPACE=""
SET $PIECE(SPACE," ",L)=""
+51 SET (L,RMPRS)=""
SET L=L+$LENGTH(RMPRCSZ)
SET $PIECE(RMPRS," ",(50-L))=""
+52 SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"RMPRT",K))
if K=""
QUIT
SET CNT=K
+53 SET ^TMP($JOB,"RMPRT",CNT+1)=" "_RMPRCSZ_RMPRS_"VETERANS PHONE: "_VAPA(8)
+54 SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"RMPRT",K))
if K=""
QUIT
SET CNT=K
+55 SET ^TMP($JOB,"RMPRT",CNT+1)=RMPRD
+56 SET ^TMP($JOB,"RMPRT",CNT+2)="6. AUTHORITY FOR ISSUANCE 7. ELIGIBILITY STATUS 8. DATE REQUIRED"
+57 SET ^TMP($JOB,"RMPRT",CNT+3)=" CFR 17.115 "_$SELECT($PIECE(VAEL(3),U,1)=1:"SC",1:"NSC")
+58 ;S ^TMP($J,"RMPRT",CNT+4)=" 9. DISABILITY CODE:"
+59 SET ^TMP($JOB,"RMPRT",CNT+5)=RMPRD
+60 SET ^TMP($JOB,"RMPRT",CNT+6)=" 10.TYPES AND QUANTITIES OF APPLIANCES AND/OR SERVICES REQUESTED"
+61 SET ^TMP($JOB,"RMPRT",CNT+7)=RMPRD
+62 SET ^TMP($JOB,"RMPRT",CNT+8)=" *UNIT *TOTAL"
+63 SET ^TMP($JOB,"RMPRT",CNT+9)=" ITEM # NOMENCLATURE QTY UNIT COST COST"
+64 SET ^TMP($JOB,"RMPRT",CNT+10)=RMPRD
+65 ; Item Multiple
+66 SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"RMPRT",K))
if K=""
QUIT
SET CNT=K
+67 SET RI=""
+68 FOR
SET RI=$ORDER(^RMPR(664.1,RMPRA,2,RI))
if RI=""
QUIT
Begin DoDot:1
+69 if '$DATA(^RMPR(664.1,RMPRA,2,RI,0))
QUIT
+70 SET CNT=CNT+1
+71 SET RMPR21=$GET(^RMPR(664.1,RMPRA,2,RI,0))
+72 IF RMPR21=""
SET RESULTS="1^No item multiple found"
+73 FOR I=1:1:11
SET RMPR21(I)=""
+74 SET RMPR21(1)=$PIECE(RMPR21,U,1)
SET RMPR21(2)=$PIECE(RMPR21,U,2)
+75 SET RMPR21(3)=$$EXTERNAL^DILFD(664.16,3,,$PIECE(RMPR21,U,3))
+76 SET RMPRINM=$$EXTERNAL^DILFD(664.16,.01,,$PIECE(RMPR21,U))
SET RMPRINM=$EXTRACT(RMPRINM,1,24)
+77 SET RMPR21(4)=$SELECT($PIECE(RMPR21,U,4)>0:$PIECE(RMPR21,U,4),1:"0.00")
+78 SET RMPR21(11)=$SELECT($PIECE(RMPR21,U,11)>0:$PIECE(RMPR21,U,11),1:"0.00")
+79 SET (L,RMPRS)=""
SET L=L+6
SET L=L+$LENGTH(RMPR21(1))
SET $PIECE(RMPRS," ",(15-L))=""
+80 SET ^TMP($JOB,"RMPRT",CNT)=" "_RMPR21(1)_RMPRS_RMPRINM
+81 SET (L,RMPRS)=""
SET L=L+$LENGTH(RMPRINM)
SET $PIECE(RMPRS," ",(29-L))=""
+82 SET ^TMP($JOB,"RMPRT",CNT)=^TMP($JOB,"RMPRT",CNT)_RMPRS_RMPR21(2)
+83 SET (L,RMPRS)=""
SET L=L+$LENGTH(RMPR21(2))
SET $PIECE(RMPRS," ",(14-L))=""
+84 SET ^TMP($JOB,"RMPRT",CNT)=^TMP($JOB,"RMPRT",CNT)_RMPRS_RMPR21(3)
+85 SET (L,RMPRS)=""
SET L=L+$LENGTH(RMPR21(3))
SET $PIECE(RMPRS," ",(8-L))=""
+86 SET ^TMP($JOB,"RMPRT",CNT)=^TMP($JOB,"RMPRT",CNT)_RMPRS_RMPR21(4)_RMPRS_RMPR21(11)
+87 SET RMPREXT=0
+88 FOR
SET RMPREXT=$ORDER(^RMPR(664.1,RMPRA,2,RI,1,RMPREXT))
if RMPREXT=""
QUIT
Begin DoDot:2
+89 SET CNT=CNT+1
+90 SET ^TMP($JOB,"RMPRT",CNT)=^RMPR(664.1,RMPRA,2,RI,1,RMPREXT,0)
End DoDot:2
+91 DO HCP
End DoDot:1
+92 SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"RMPRT",K))
if K=""
QUIT
SET CNT=K
+93 SET ^TMP($JOB,"RMPRT",CNT+1)=RMPRD
+94 SET ^TMP($JOB,"RMPRT",CNT+2)="11. PROCUREMENT SOURCE: "_RMPRSOP
+95 SET ^TMP($JOB,"RMPRT",CNT+3)=RMPRD
+96 SET ^TMP($JOB,"RMPRT",CNT+4)="12. SIGNATURE AND TITLE OF 13. DATE 14. SIGNATURE AND TITLE OF 15. DATE"
+97 SET ^TMP($JOB,"RMPRT",CNT+5)=" REQUESTING OFFICIAL "_RMPRRDT_" APPROVING OFFICIAL"
+98 SET (L,RMPRS)=""
SET L=+$LENGTH(RMPRROF)
SET $PIECE(RMPRS," ",(46-L))=""
+99 SET ^TMP($JOB,"RMPRT",CNT+6)=" "_RMPRROF_RMPRS_RMPRAOF
+100 SET ^TMP($JOB,"RMPRT",CNT+7)=RMPRD
+101 SET ^TMP($JOB,"RMPRT",CNT+8)=" SECTION III"
+102 SET ^TMP($JOB,"RMPRT",CNT+9)=RMPRL
+103 SET ^TMP($JOB,"RMPRT",CNT+10)="16. ORDER NUMBER 17. DATE OF ORDER 18. DATE ITEM RECIEVED"
+104 SET (L,RMPRS)=""
SET L=$LENGTH($PIECE(RMPR0,U,13))
SET $PIECE(RMPRS," ",(30-L))=""
+105 SET ^TMP($JOB,"RMPRT",CNT+11)=" "_$PIECE(RMPR0,U,13)_RMPRS_RMPRODT
+106 SET ^TMP($JOB,"RMPRT",CNT+12)=RMPRD
+107 SET ^TMP($JOB,"RMPRT",CNT+13)="19. DATE DELIVERED 20. SIGNATURE OF INSPECTING OFFICIAL"
+108 SET ^TMP($JOB,"RMPRT",CNT+14)=""
+109 SET ^TMP($JOB,"RMPRT",CNT+15)=RMPRD
+110 SET ^TMP($JOB,"RMPRT",CNT+16)="21. CERTIFICATE OF RECEIPT OR DELIVERY (Check One)"
+111 SET ^TMP($JOB,"RMPRT",CNT+17)=RMPRD
+112 SET ^TMP($JOB,"RMPRT",CNT+18)="[ ] I certify that I have received the items listed above"
+113 SET ^TMP($JOB,"RMPRT",CNT+19)="[ ] I certify that the above item(s) have been sent to"
+114 SET ^TMP($JOB,"RMPRT",CNT+20)=" the Veteran or the requesting field station"
+115 SET ^TMP($JOB,"RMPRT",CNT+21)=RMPRD
+116 SET ^TMP($JOB,"RMPRT",CNT+22)="22. SIGNATURE OF VETERAN OR VA OFFICIAL"
+117 SET ^TMP($JOB,"RMPRT",CNT+23)=""
+118 SET ^TMP($JOB,"RMPRT",CNT+24)=RMPRD
+119 SET ^TMP($JOB,"RMPRT",CNT+25)="23 SIGNATURE OF DESIGNATED EMPLOYEE 24. DATE 25. STATION NO."
+120 SET RMPRSTN=""
IF $DATA(RMPR("STA"))
SET RMPRSTN=$PIECE($GET(^DIC(4,+RMPR("STA"),99)),U)
+121 SET ^TMP($JOB,"RMPRT",CNT+26)=" "_RMPRCDT_" "_RMPRSTN
+122 SET ^TMP($JOB,"RMPRT",CNT+27)=RMPRD
+123 SET ^TMP($JOB,"RMPRT",CNT+28)="ADP FORM 2529-3"
+124 MERGE RESULTS=^TMP($JOB,"RMPRT")
+125 GOTO EXIT
+126 QUIT
HCP ;print HCPCS and GIP or Pros Inventory in -3.
+1 if RI'>0
QUIT
+2 SET RD0=RMPRA
SET RD1=RI
+3 if '$DATA(^RMPR(664.1,RD0,2,RD1,0))
QUIT
+4 SET R643=$GET(^RMPR(664.1,RD0,2,RD1,3))
+5 SET RPSAITEM=$PIECE(R643,U,3)
SET RPSALOC=$PIECE(R643,U,4)
+6 SET RPHCPC=$PIECE($GET(^RMPR(664.1,RD0,2,RD1,2)),U,1)
+7 if '$GET(RPHCPC)
QUIT
+8 if '$DATA(^RMPR(661.1,RPHCPC,0))
QUIT
+9 SET RPGIP=$PIECE($GET(^RMPR(664.1,RD0,2,RD1,0)),U,13)
+10 SET ^TMP($JOB,"RMPRT",CNT+1)=" HCPCS: "_$PIECE(^RMPR(661.1,RPHCPC,0),U,1)
+11 IF $GET(RPSALOC)
IF RPSAITEM'=""
IF $DATA(^RMPR(661.3,RPSALOC,0))
Begin DoDot:1
+12 SET RHDA=$ORDER(^RMPR(661.3,RPSALOC,1,"B",RPHCPC,0))
if '$GET(RHDA)
QUIT
+13 SET RIDA=$ORDER(^RMPR(661.3,RPSALOC,1,RHDA,1,"B",RPSAITEM,0))
+14 SET RIDES=$PIECE($GET(^RMPR(661.3,RPSALOC,1,RHDA,1,RIDA,0)),U,8)
+15 SET ^TMP($JOB,"RMPRT",CNT+1)=^TMP($JOB,"RMPRT",CNT+1)_" RIDES"
End DoDot:1
+16 IF $GET(RPSALOC)
SET ^TMP($JOB,"RMPRT",CNT+2)="*** Pros Inventory *** Location: "
+17 IF $GET(RPSALOC)
if $DATA(^RMPR(661.3,RPSALOC,0))
SET ^TMP($JOB,"RMPRT",CNT+2)=^TMP($JOB,"RMPRT",CNT+2)_$PIECE(^RMPR(661.3,RPSALOC,0),U,1)
+18 IF '$GET(RPSALOC)
IF $GET(RPGIP)
SET ^TMP($JOB,"RMPRT",CNT+2)=" *** GIP ***"
+19 IF '$GET(RPSALOC)
IF '$GET(RPGIP)
SET ^TMP($JOB,"RMPRT",CNT+2)=" *** OTHER ***"
+20 QUIT
EXIT ;common exit point
+1 KILL RMPRA,RMPRSITE,RMPRPTR,RMPRINS,RMPRST,RMPRAD,DIC,DFN
+2 KILL RA,RB,RFL,RMPRCT,RMPRI,RMPRSC,RMPRWO,RMPR9P,SRC,TO,X,Y
+3 DO KVAR^VADPT
+4 QUIT
