- 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 Feb 18, 2025@23:58:58 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