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

RMPR29W.m

Go to the documentation of this file.
  1. RMPR29W ;PHX/JLT/HNB-DISPLAY JOB RECORD HDR AND ITEM [ 11/04/94 10:07 AM ]
  1. ;;3.0;PROSTHETICS;;Feb 09, 1996
  1. GET(PRDA) ;INFOR FOR JOB SECTION
  1. K RMPRWO
  1. S DFN=$P(^RMPR(664.1,PRDA,0),U,2),SRC=$P(^(0),U,11)
  1. D KVAR^VADPT,DEM^VADPT,ELIG^VADPT
  1. K DIQ,TMP,TECH,^UTILITY($J,"TEXT"),^UTILITY("DIQ1",$J)
  1. S DIC="^RMPR(664.1,"
  1. S DA=PRDA,DR=".02;4;12;12.1;12.2;12.3;12.4;13;15;19"
  1. D EN^DIQ1
  1. S RI=0
  1. K RCK
  1. F S RI=$O(^RMPR(664.1,PRDA,2,RI)) Q:RI'>0 Q:'$D(^RMPR(664.1,PRDA,2,RI,0)) D
  1. .S DA=PRDA,DIC="^RMPR(664.1,"
  1. .S DR="6",DR(664.16)=".01;2;3;8;10",DA(664.16)=RI
  1. .S DA660=$P(^RMPR(664.1,PRDA,2,RI,0),U,5),TYPE=$P(^(0),U,7)
  1. .I +DA660 S RMPRWO=$O(^RMPR(664.2,"C",DA660,0))
  1. .Q:'+$G(RMPRWO)
  1. .S RMPRJOB=$P(^RMPR(664.2,RMPRWO,0),U,4)
  1. .S RCK(RMPRJOB)=$$ITM1^RMPR31U(+$P(^RMPR(664.1,PRDA,2,RI,0),U))_U_DA660_U_RMPRWO_U_RI_U_TYPE
  1. .D EN^DIQ1
  1. I '$D(RCK) Q
  1. K DR S RI=0
  1. F S RI=$O(RCK(RI)) Q:RI'>0 D
  1. .S DIC="^RMPR(664.2,",DR="4;5;8;9;10;11;12"
  1. .S (RMPRWO,DA)=$P(RCK(RI),U,3)
  1. .S DIQ(0)="IE" D EN^DIQ1 K DIQ
  1. .K DR S DA=RMPRWO,RJ=0
  1. .F S RJ=$O(^RMPR(664.2,DA,1,RJ)) Q:RJ'>0 D
  1. ..S DIQ="TMP("_DA_",",DA(664.22)=RJ
  1. ..S DR="2",DR(664.22)=".01;1;2;3;4;6;10;11"
  1. ..D EN^DIQ1 K DIQ
  1. ..I $P($G(^RMPR(664.2,DA,1,RJ,0)),U,11) S TMP(DA,664.22,RJ,3)="P"
  1. .D WP
  1. S RI=0
  1. F S RI=$O(RCK(RI)) Q:RI'>0 D
  1. .S RDA=$P(RCK(RI),U,2),RMPRWO=$P(RCK(RI),U,3)
  1. .Q:'+RDA
  1. .S DA=0
  1. .F S DA=$O(^RMPR(664.3,"C",RDA,DA)) Q:DA'>0 I $D(^RMPR(664.3,DA,0)) S RMPRDT=$P(^(0),U) D
  1. ..K DR S RT=0
  1. ..F S RT=$O(^RMPR(664.3,DA,1,RT)) Q:RT'>0 D
  1. ...S DIC="^RMPR(664.3,"
  1. ...;DIQ array should start with DI
  1. ...S DIQ(0)="IE",DIQ="TECH("_RMPRWO_","_RMPRDT_","
  1. ...S DA(664.33)=RT,DR="3",DR(664.33)=".01;1;2"
  1. ...D EN^DIQ1 K DIQ
  1. Q
  1. ;see internal notes
  1. EXIT ;common exit
  1. K DA,DA660,DFN,DIRUT,DIWF,DIWL,DTOUT,PAGE,PDA,PRDA,RMPRBACK
  1. K RMPRDA,RMPRDFN,RMPRDIR3,RMPRDIR7,RMPRDT,RMPRJOB
  1. K RMPRWO,XRC,VADM,VAEL,TYPE,RDA,RJ,RT,RWP,RR Q
  1. Q
  1. HDR(PRDA) ;DISPLAY JOB RECORD HEADER
  1. ;
  1. S PAGE=PAGE+1
  1. W @IOF,!,?31,"JOB RECORD SECTION",?65,"PAGE:"
  1. W ?72,PAGE,!,?19,"(To be completed by VA Shop or Clinic only)"
  1. W !,"VETERAN",?25,"CLAIM #",?37,"WARD",?52,"SSN"
  1. W ?64,"WORK ORDER #",!,RMPR("L")
  1. W !,"|"_^UTILITY("DIQ1",$J,664.1,PRDA,.02)
  1. W ?24,"|"_$P($G(VAEL(7)),U),?36,"|"_^UTILITY("DIQ1",$J,664.1,PRDA,12)
  1. W ?51,"|"_$P(VADM(2),U)
  1. W ?64,"|"_^UTILITY("DIQ1",$J,664.1,PRDA,4),!,RMPR("L")
  1. W !,"|DATE ASSIGNED:",?16,^UTILITY("DIQ1",$J,664.1,PRDA,19)
  1. W ?36,"|ASSIGNED TO: ",^UTILITY("DIQ1",$J,664.1,PRDA,15),!,RMPR("L")
  1. I ^UTILITY("DIQ1",$J,664.1,PRDA,12)'="" W !,"|PHYSICIAN:",?16,^(12.1),?42,"|DIAGNOSIS:",?57,^(12.2),!,?0,"|TREATING SPEC:",?16,^(12.3),?42,"|EXT:",?57,^(12.4),!,RMPR("L")
  1. Q
  1. ;
  1. WP ;use DIWP to print REMARKS word processing field
  1. ;
  1. K ^UTILITY($J,"W") S RWP=0,RW=0
  1. F S RW=$O(^UTILITY("DIQ1",$J,664.2,RMPRWO,12,RW)) Q:RW'>0 D
  1. .S X=^(RW)
  1. .S DIWF="R",DIWL=1,DIWR=79
  1. .D ^DIWP
  1. .S RR=0
  1. .F S RR=$O(^UTILITY($J,"W",DIWL,RR)) Q:RR'>0 D
  1. ..S RWP=RWP+1,^UTILITY($J,"TEXT",RMPRWO,RWP)=^(RR,0)
  1. ..K ^UTILITY($J,"W")
  1. Q
  1. HD ;print header
  1. W @IOF
  1. W ?10,"REQUEST AND RECEIPT FOR PROSTHETIC APPLIANCES OR SERVICES"
  1. W ?70,"PAGE:",?77,PAGE,!,?34,"(Section I)"
  1. W !,"VETERAN",?25,"WORK ORDER #",?44,"VENDOR",?60,"REQUESTOR"
  1. W !,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,.02),1,20)
  1. W ?24,"|"_^UTILITY("DIQ1",$J,664.1,RMPRDA,4)
  1. W ?43,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,2),1,15),?59,"|"_$E(^(13),1,20)
  1. W !,"|ORDERING STATION: ",?25,^UTILITY("DIQ1",$J,664.1,RMPRDA,.04)
  1. W !,RMPR("L"),!,"|AUTHORITY: CFR 17.115",?42,"|DATE REQUIRED:"
  1. W ?57,^UTILITY("DIQ1",$J,664.1,RMPRDA,.09)
  1. W !,RMPR("L"),!,"|ASSIGNED TO:"
  1. W ?16,^UTILITY("DIQ1",$J,664.1,RMPRDA,15),?42,"|DATE ASSIGNED:"
  1. W ?57,^UTILITY("DIQ1",$J,664.1,RMPRDA,19),!,RMPR("L")
  1. Q
  1. ;
  1. HDC ;print header of mult. page
  1. W @IOF
  1. W ?10,"REQUEST AND RECEIPT FOR PROSTHETIC APPLIANCES OR SERVICES"
  1. W ?70,"PAGE:",?77,PAGE,!,?34,"(Section I)"
  1. W !,"VETERAN",?44,"VENDOR",?60,"REQUESTOR"
  1. W !,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,.02),1,20)
  1. W ?43,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,2),1,15)
  1. W ?59,"|"_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,13),1,20),!,RMPR("L")
  1. W !,"|TO: "_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,.11),1,30)
  1. W ?42,"ORDERING STATION: "_$E(^UTILITY("DIQ1",$J,664.1,RMPRDA,.04),1,20),RMPR("L")
  1. W !,"|AUTHORITY: CFR 17.115",?42,"|DATE REQUIRED:",?57,^(.09)
  1. W !,RMPR("L")
  1. Q
  1. ;
  1. HELP ;DISPLAY HELP FOR SCREENS
  1. ;
  1. N RMPR90DP,RMPR90I
  1. W !
  1. S RMPR90DP=$P(DIR(0),U,2,999)
  1. F RMPR90I=1:1:6 I $P($P(RMPR90DP,";",RMPR90I),":",1)'="" W:RMPR90I=4 ! W "("_$P($P(RMPR90DP,";",RMPR90I),":",1)_") "_$P($P(RMPR90DP,";",RMPR90I),":",2)_" "
  1. W !
  1. Q
  1. ;
  1. DIS(RMPRDFN,PDA) ;GET DISABILITY CODES PASS RMPRDFN AND PDA
  1. ;
  1. LK ;do a lookup on 2529-3 record patient/disability code
  1. K DIR S DIR(0)=$S($O(^RMPR(664.1,RMPRDA,1,0)):"FO",1:"F")
  1. S DIR("A")="Select 2529-3 DISABILITY CODE"
  1. S DIR("?")="^D DSP^RMPR29W"
  1. D ^DIR Q:$D(DTOUT)!($D(DIRUT))
  1. K DIC
  1. S DIC("W")="S RA=^(0) D LP^RMPRDIS"
  1. S DIC("S")="I '$P(^(0),U,10)"
  1. S DIC="^RMPR(665,"_RMPRDFN_",1,"
  1. S DIC("P")="665.01IP",DIC(0)="EQMZ"
  1. D ^DIC G:+Y'>0 LK
  1. Q
  1. ;
  1. DSP ;DISPLAY DISABILITY CODES
  1. ;see internal notes 6/23/95
  1. ;Q:'$D(^RMPR(664.1,PDA,1,0))
  1. D LP^RMPRDIS
  1. ;W !!,?5,"Select 2529-3 DISABILITY CODE",!
  1. S RI=0
  1. F S RI=$O(^RMPR(664.1,PDA,1,RI)) Q:RI'>0 I $D(^(RI,0)) S RT=^(0) W !,?5,$P($G(^RMPR(662,+RT,0)),U),?15,$S($P(RT,U,2)=1:"SC ",1:"NSC ")
  1. K RI
  1. W !
  1. S (RMPRDIR7,RMPRDIR3,RMPRBACK)=1 W !! D EN^RMPRDIS
  1. Q