- 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 Jan 18, 2025@03:33:36 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