Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPR29RG

RMPR29RG.m

Go to the documentation of this file.
  1. RMPR29RG ;HIOFO/SPS-OWL WINDOWS PRINTER [ 12/01/05 5:39 AM ]
  1. ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25
  1. ;get basic info, system variables
  1. ;WINDOW FAX/PRINT 2529-3 PASS RMPRA
  1. ;REQUIRED VARIABLES: RMPRDA - ENTRY NUMBER IN FILE 664.1
  1. ; RMPRSITE - SITE OFSTATION PROCESSING 2529-3
  1. ; RMPRPTR - "WINDOWS"
  1. IN(RMPRA,RMPRSITE,RMPRPTR) ;
  1. ;TEST ENTRY
  1. D IN2
  1. Q
  1. K CNT,I,K,L,LCN,LNM,LSSN,LSTN,R643,RDO,RDI,RHDA,RI,RIDA,RIDES,RMPR,RMPR0
  1. K RMPR21,RMPRAOF,RMPRCDT,RMPRCSZ,RMPRD,RMPRDA,RMPREXT,RMPRINM,RMPRINSN
  1. K RMPRL,RMPRODT,RMPRRDT,RMPRROF,RMPRS,RMPRSOP,RMPRSTN,RMPGIP,RPHCPC
  1. K RD0,RD1,RPGIP,RPSAITEM,RPSALOC,SPACE,VA,VADM,VAEL,VAPA
  1. PRT(RESULTS,RMPRA,RMPRSITE,RMPRPTR) ;GUI ENTRY
  1. IN2 I RMPRPTR'="WINDOWS" S RMPRDA=RMPRA G PRT^RMPR29R
  1. K ^TMP($J,"RMPRT"),RESULTS
  1. S DIC=4,DIC(0)="QZN",X=$P(^RMPR(664.1,RMPRA,0),U,15)
  1. D ^DIC G:+Y'>0 EXIT
  1. N RC
  1. S RMPRINS=+Y,RC=0,RMPRINSN=$P(^DIC(4,RMPRINS,99),U)
  1. S RMPRST=$S($D(^DIC(5,+$P(Y(0),U,2),0)):$P(^(0),U),1:"")
  1. S (RMPRAD(1),RMPRAD(2),RMPRCT,RMPR9P)=""
  1. 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)
  1. S DFN=$P(^RMPR(664.1,RMPRA,0),U,2) D ALL^VADPT
  1. ;
  1. I $P(^RMPR(664.1,RMPRA,0),U,11)="N" N RMPRFCTR D
  1. .;national footwear center address in RMPRFCTR array used in print
  1. .;template RMPR 25293
  1. .S RMPRFCTR(1)="179TH ST & LINDEN BLVD."
  1. .S RMPRFCTR(2)="ST. ALBANS, NY 11425"
  1. ;
  1. S RMPR0=^RMPR(664.1,RMPRA,0)
  1. S RMPRRDT=$$EXTERNAL^DILFD(664.1,17,,$P(RMPR0,U,18))
  1. S RMPRCDT=$$EXTERNAL^DILFD(664.1,23,,$P(RMPR0,U,26))
  1. S RMPRROF=$$EXTERNAL^DILFD(664.1,13,,$P(RMPR0,U,5))
  1. S RMPRAOF=$$EXTERNAL^DILFD(664.1,14,,$P(RMPR0,U,7))
  1. S RMPRODT=$$EXTERNAL^DILFD(664.1,.01,,$P(RMPR0,U,1))
  1. S (RMPRL,RMPRD,RMPRS)="",$P(RMPRL,"_",81)="",$P(RMPRD,"-",81)=""
  1. S ^TMP($J,"RMPRT",0)=" REQUEST AND RECEIPT FOR PROSTHETIC APPLIANCES OR SERVICES "
  1. S ^TMP($J,"RMPRT",1)=RMPRL
  1. S ^TMP($J,"RMPRT",2)=" SECTION I"
  1. S ^TMP($J,"RMPRT",3)=RMPRD
  1. S RMPRSOP=$$EXTERNAL^DILFD(664.1,2,,$P(RMPR0,U,11))
  1. S ^TMP($J,"RMPRT",4)="TO: | "_RMPRSOP
  1. S L=$L(RMPRSOP),L=L+38,$P(RMPRS," ",80-L)=""
  1. S (L,RMPRS)="",L=$L(RMPRSOP),L=L+6,$P(RMPRS," ",(45-L))=""
  1. S ^TMP($J,"RMPRT",4)=^TMP($J,"RMPRT",4)_RMPRS_"1. VETERANS NAME (LAST,FIRST,M.I.)"
  1. S ^TMP($J,"RMPRT",5)=" "_$$EXTERNAL^DILFD(664.1,.11,,$P(RMPR0,U,15))
  1. S (L,RMPRS)="",L=$L($$EXTERNAL^DILFD(664.1,.11,,$P(RMPR0,U,15))),L=L+6,$P(RMPRS," ",(49-L))=""
  1. S ^TMP($J,"RMPRT",5)=^TMP($J,"RMPRT",5)_RMPRS_VADM(1)
  1. I RMPRAD(1)'="" S ^TMP($J,"RMPRT",6)=" "_$E(RMPRAD(1),1,30)
  1. I RMPRAD(2)'="" S ^TMP($J,"RMPRT",7)=" "_$E(RMPRAD(2),1,30)
  1. S ^TMP($J,"RMPRT",8)=" "_RMPRCT_", "_RMPRST_" "_RMPR9P
  1. S ^TMP($J,"RMPRT",9)=RMPRD
  1. S ^TMP($J,"RMPRT",10)="2. VETERANS ADDRESS 3. CLAIM NO. 4. SSN 5. STATION NO."
  1. S LNM=$L(VADM(1)),LCN=$L(VAEL(7)),LSSN=$L(VA("PID")),LSTN=$L(RMPRINSN)
  1. S (L,RMPRS)="",L=$L(VADM(1)),L=L+3,$P(RMPRS," ",(36-L))=""
  1. S ^TMP($J,"RMPRT",11)=" "_VADM(1)_RMPRS_VAEL(7)
  1. S (L,RMPRS)="",L=L+$L(VAEL(7)),$P(RMPRS," ",(17-L))=""
  1. S ^TMP($J,"RMPRT",11)=^TMP($J,"RMPRT",11)_RMPRS_VA("PID")_" "_RMPRINSN
  1. S ^TMP($J,"RMPRT",12)=" "_VAPA(1)
  1. I VAPA(2)'="" S ^TMP($J,"RMPRT",13)=" "_VAPA(2)
  1. I VAPA(3)'="" S ^TMP($J,"RMPRT",14)=" "_VAPA(3)
  1. S RMPRCSZ=$P(VAPA(4),U,1)_","_$P(VAPA(5),U,2)_" "_VAPA(6)
  1. S L=$L(RMPRCSZ),L=50-L,SPACE="",$P(SPACE," ",L)=""
  1. S (L,RMPRS)="",L=L+$L(RMPRCSZ),$P(RMPRS," ",(50-L))=""
  1. S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
  1. S ^TMP($J,"RMPRT",CNT+1)=" "_RMPRCSZ_RMPRS_"VETERANS PHONE: "_VAPA(8)
  1. S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
  1. S ^TMP($J,"RMPRT",CNT+1)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+2)="6. AUTHORITY FOR ISSUANCE 7. ELIGIBILITY STATUS 8. DATE REQUIRED"
  1. S ^TMP($J,"RMPRT",CNT+3)=" CFR 17.115 "_$S($P(VAEL(3),U,1)=1:"SC",1:"NSC")
  1. ;S ^TMP($J,"RMPRT",CNT+4)=" 9. DISABILITY CODE:"
  1. S ^TMP($J,"RMPRT",CNT+5)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+6)=" 10.TYPES AND QUANTITIES OF APPLIANCES AND/OR SERVICES REQUESTED"
  1. S ^TMP($J,"RMPRT",CNT+7)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+8)=" *UNIT *TOTAL"
  1. S ^TMP($J,"RMPRT",CNT+9)=" ITEM # NOMENCLATURE QTY UNIT COST COST"
  1. S ^TMP($J,"RMPRT",CNT+10)=RMPRD
  1. ; Item Multiple
  1. S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
  1. S RI=""
  1. F S RI=$O(^RMPR(664.1,RMPRA,2,RI)) Q:RI="" D
  1. .Q:'$D(^RMPR(664.1,RMPRA,2,RI,0))
  1. .S CNT=CNT+1
  1. .S RMPR21=$G(^RMPR(664.1,RMPRA,2,RI,0))
  1. .I RMPR21="" S RESULTS="1^No item multiple found"
  1. .F I=1:1:11 S RMPR21(I)=""
  1. .S RMPR21(1)=$P(RMPR21,U,1),RMPR21(2)=$P(RMPR21,U,2)
  1. .S RMPR21(3)=$$EXTERNAL^DILFD(664.16,3,,$P(RMPR21,U,3))
  1. .S RMPRINM=$$EXTERNAL^DILFD(664.16,.01,,$P(RMPR21,U)),RMPRINM=$E(RMPRINM,1,24)
  1. .S RMPR21(4)=$S($P(RMPR21,U,4)>0:$P(RMPR21,U,4),1:"0.00")
  1. .S RMPR21(11)=$S($P(RMPR21,U,11)>0:$P(RMPR21,U,11),1:"0.00")
  1. .S (L,RMPRS)="",L=L+6,L=L+$L(RMPR21(1)),$P(RMPRS," ",(15-L))=""
  1. .S ^TMP($J,"RMPRT",CNT)=" "_RMPR21(1)_RMPRS_RMPRINM
  1. .S (L,RMPRS)="",L=L+$L(RMPRINM),$P(RMPRS," ",(29-L))=""
  1. .S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(2)
  1. .S (L,RMPRS)="",L=L+$L(RMPR21(2)),$P(RMPRS," ",(14-L))=""
  1. .S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(3)
  1. .S (L,RMPRS)="",L=L+$L(RMPR21(3)),$P(RMPRS," ",(8-L))=""
  1. .S ^TMP($J,"RMPRT",CNT)=^TMP($J,"RMPRT",CNT)_RMPRS_RMPR21(4)_RMPRS_RMPR21(11)
  1. .S RMPREXT=0
  1. .F S RMPREXT=$O(^RMPR(664.1,RMPRA,2,RI,1,RMPREXT)) Q:RMPREXT="" D
  1. ..S CNT=CNT+1
  1. ..S ^TMP($J,"RMPRT",CNT)=^RMPR(664.1,RMPRA,2,RI,1,RMPREXT,0)
  1. .D HCP
  1. S K="" F S K=$O(^TMP($J,"RMPRT",K)) Q:K="" S CNT=K
  1. S ^TMP($J,"RMPRT",CNT+1)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+2)="11. PROCUREMENT SOURCE: "_RMPRSOP
  1. S ^TMP($J,"RMPRT",CNT+3)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+4)="12. SIGNATURE AND TITLE OF 13. DATE 14. SIGNATURE AND TITLE OF 15. DATE"
  1. S ^TMP($J,"RMPRT",CNT+5)=" REQUESTING OFFICIAL "_RMPRRDT_" APPROVING OFFICIAL"
  1. S (L,RMPRS)="",L=+$L(RMPRROF),$P(RMPRS," ",(46-L))=""
  1. S ^TMP($J,"RMPRT",CNT+6)=" "_RMPRROF_RMPRS_RMPRAOF
  1. S ^TMP($J,"RMPRT",CNT+7)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+8)=" SECTION III"
  1. S ^TMP($J,"RMPRT",CNT+9)=RMPRL
  1. S ^TMP($J,"RMPRT",CNT+10)="16. ORDER NUMBER 17. DATE OF ORDER 18. DATE ITEM RECIEVED"
  1. S (L,RMPRS)="",L=$L($P(RMPR0,U,13)),$P(RMPRS," ",(30-L))=""
  1. S ^TMP($J,"RMPRT",CNT+11)=" "_$P(RMPR0,U,13)_RMPRS_RMPRODT
  1. S ^TMP($J,"RMPRT",CNT+12)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+13)="19. DATE DELIVERED 20. SIGNATURE OF INSPECTING OFFICIAL"
  1. S ^TMP($J,"RMPRT",CNT+14)=""
  1. S ^TMP($J,"RMPRT",CNT+15)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+16)="21. CERTIFICATE OF RECEIPT OR DELIVERY (Check One)"
  1. S ^TMP($J,"RMPRT",CNT+17)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+18)="[ ] I certify that I have received the items listed above"
  1. S ^TMP($J,"RMPRT",CNT+19)="[ ] I certify that the above item(s) have been sent to"
  1. S ^TMP($J,"RMPRT",CNT+20)=" the Veteran or the requesting field station"
  1. S ^TMP($J,"RMPRT",CNT+21)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+22)="22. SIGNATURE OF VETERAN OR VA OFFICIAL"
  1. S ^TMP($J,"RMPRT",CNT+23)=""
  1. S ^TMP($J,"RMPRT",CNT+24)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+25)="23 SIGNATURE OF DESIGNATED EMPLOYEE 24. DATE 25. STATION NO."
  1. S RMPRSTN="" I $D(RMPR("STA")) S RMPRSTN=$P($G(^DIC(4,+RMPR("STA"),99)),U)
  1. S ^TMP($J,"RMPRT",CNT+26)=" "_RMPRCDT_" "_RMPRSTN
  1. S ^TMP($J,"RMPRT",CNT+27)=RMPRD
  1. S ^TMP($J,"RMPRT",CNT+28)="ADP FORM 2529-3"
  1. M RESULTS=^TMP($J,"RMPRT")
  1. G EXIT
  1. Q
  1. HCP ;print HCPCS and GIP or Pros Inventory in -3.
  1. Q:RI'>0
  1. S RD0=RMPRA,RD1=RI
  1. Q:'$D(^RMPR(664.1,RD0,2,RD1,0))
  1. S R643=$G(^RMPR(664.1,RD0,2,RD1,3))
  1. S RPSAITEM=$P(R643,U,3),RPSALOC=$P(R643,U,4)
  1. S RPHCPC=$P($G(^RMPR(664.1,RD0,2,RD1,2)),U,1)
  1. Q:'$G(RPHCPC)
  1. Q:'$D(^RMPR(661.1,RPHCPC,0))
  1. S RPGIP=$P($G(^RMPR(664.1,RD0,2,RD1,0)),U,13)
  1. S ^TMP($J,"RMPRT",CNT+1)=" HCPCS: "_$P(^RMPR(661.1,RPHCPC,0),U,1)
  1. I $G(RPSALOC),RPSAITEM'="",$D(^RMPR(661.3,RPSALOC,0)) D
  1. .S RHDA=$O(^RMPR(661.3,RPSALOC,1,"B",RPHCPC,0)) Q:'$G(RHDA)
  1. .S RIDA=$O(^RMPR(661.3,RPSALOC,1,RHDA,1,"B",RPSAITEM,0))
  1. .S RIDES=$P($G(^RMPR(661.3,RPSALOC,1,RHDA,1,RIDA,0)),U,8)
  1. .S ^TMP($J,"RMPRT",CNT+1)=^TMP($J,"RMPRT",CNT+1)_" RIDES"
  1. I $G(RPSALOC) S ^TMP($J,"RMPRT",CNT+2)="*** Pros Inventory *** Location: "
  1. 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)
  1. I '$G(RPSALOC),$G(RPGIP) S ^TMP($J,"RMPRT",CNT+2)=" *** GIP ***"
  1. I '$G(RPSALOC),'$G(RPGIP) S ^TMP($J,"RMPRT",CNT+2)=" *** OTHER ***"
  1. Q
  1. EXIT ;common exit point
  1. K RMPRA,RMPRSITE,RMPRPTR,RMPRINS,RMPRST,RMPRAD,DIC,DFN
  1. K RA,RB,RFL,RMPRCT,RMPRI,RMPRSC,RMPRWO,RMPR9P,SRC,TO,X,Y
  1. D KVAR^VADPT
  1. Q