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