RMPFQP3 ;DDC/KAW-PRINT VA FORM 10-2477a [ 03/12/98 7:46 AM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**10**;;JUN 16, 1995
; input: RMPFX
;output: None
F KX=1:1:RMPFCNT D PRINT
G END
PRINT Q:'$D(RMPFX) Q:'RMPFX Q:'$D(^RMPF(791810,RMPFX,0)) S RMPFTYP=$P(^(0),U,2)
D ^RMPFQP1 S DFN=$P(^RMPF(791810,RMPFX,0),U,4)
D ^RMPFDT5,^RMPFDD2,HEAD,HEAD1,ELG,P1 G END:$D(RMPFOUT)
W !,"9. Currently Authorized Hearing Aid(s)"
S X=$O(^RMPF(791810,RMPFX,301,0)) I X,$D(^(X,0)) S Y=$P(^(0),U,8) I Y D DD^%DT W " as of: ",Y
D LINE
W !?2,"Manfacturer",?16,"|",?22,"Model",?32,"|",?34,"Serial Number",?48,"|",?50,"Furnished By",?64,"|",?67,"Date Issued"
D LINE
I $D(^RMPF(791810,RMPFX,301,0)) D AUTH^RMPFQP4 G NEXT
F I=1:1:4 W !,?16,"|",?32,"|",?48,"|",?64,"|" D LINE
NEXT I $Y>19 D CONT^RMPFQP2
W !,"10. Clinic Action Taken __ VETERAN DOES NOT REQUIRE NEW HEARING AID"
W !?27,"__ VETERAN DOES NOT REQUIRE HEARING AID"
W !?27,"__ ITEM(S) LISTED BELOW WERE ISSUED TO VETERAN"
D LINE
D CONT^RMPFQP2 G END:$D(RMPFOUT) D LINE:IOST?1"C-".E
CLINIC W !,?16,"|",?27,"|",?44,"|",?57,"| Battery",?67,"| Serial No."
W !,"Natl. Stock No.",?16,"|",?20,"Make",?27,"|",?33,"Model"
W ?44,"| Serial No.",?57,"| Type",?67,"| Replaced"
D LINE
D MOD^RMPFQP1
D CONT^RMPFQP2 G END:$D(RMPFOUT) D LINE:IOST?1"C-".E
I $Y>58 D CONT
W !,"11. Type of Fitting",?28,":",?32,RMPFTF
D LINE
I $Y>58 D CONT
I RMPFTYP=11 S RMPFUS="*** LOANER AID ***"
W !,"12. Authorized Usage of Aids:",?32,RMPFUS
D LINE
I $Y>58 D CONT
W !,"13. Issued aids to be replaced to clinic stock by DDC:",?56
I RMPFHAT="S" W RMPFDDC
E W "N/A"
D LINE
I $Y>58 D CONT
W !,"14. Signature of Issuing Audiologist",?38,"|",?49,"Title",?65,"|15. Order Date"
W !?38,"|",?65,"|"
I $D(RMPFX) D ARRAY^RMPFDT2 S X=0 F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,90)),$P(^(90),U,12) S Y=$P(^(90),U,12) I Y,$D(^VA(200,Y,0)) S RMPFADP=$P(^(0),U,1),RMPFAD=Y
S T="Audiologist" I RMPFAD,$D(^VA(200,RMPFAD,0)) S X=$P(^(0),U,9) I X,$D(^DIC(3.1,X,0)) S T=$P(^(0),U,1)
S T=$E(T,1,26),L=$L(T)
W !?4,$P(RMPFADP,",",2)_" "_$P(RMPFADP,",",1),?38,"|",?39+((26-L)\2),T,?65,"|",?68,RMPFODP
D LINE
I $Y>58 D CONT
W !,"16. I certify that I have",?37,"Signature of Veteran",?65,"|17. Date"
W !?4,"received the item(s)",?65,"|"
W !?4,"listed under 10 above ->",?65,"|"
D LINE
W !,"VA Form 10-2477a"
W !,"SEP 1991"
D CONT^RMPFQP2 I IOST?1"P-".E W @IOF
D:$D(IO("S")) ^%ZISC
END D KIL^RMPFQP4 Q
P1 S AD="A" G P2:'$D(RMPFX)
I $D(^RMPF(791810,RMPFX,1)) S S1=^(1) I $P(S1,U,5)'=""&($P(S1,U,6)'="") D G P3
.S C=1 K RMPFA
.F I=1:1:3 I $P(S1,U,I)'="" S RMPFA(C)=$P(S1,U,I),C=C+1
.S RMPFA(C)=$P(S1,U,4)_", "_$P(^DIC(5,$P(S1,U,5),0),U,2)_" "_$P(S1,U,6)
.Q
P2 S:$D(RMPFT) AD="T"
P3 W !,"1. Extended Audiology Clinic",?38,"| 2. Issuing Audiology Clinic"
W !?3,"Station No. ",RMPFRSTA,?38,"|",?44,"Station No. ",RMPFSTAP
W !?38,"|"
F I=1:1:4 W ! W:$D(RMPFR(I)) ?3,$E(RMPFR(I),1,35) W ?38,"|" W:$D(RMPFS(I)) ?44,$E(RMPFS(I),1,36)
D LINE
W !,"3. Veteran's Name and Address ",?38,"| 4. Eligibility Status(es) ",?71,$J($E(RMPFELS,1,9),9)
W !,?38,"|" I RMPFELD W ?70,$E(RMPFELD,4,5)_"-"_$E(RMPFELD,6,7)_"-"_($E(RMPFELD,1,3)+1700)
S RMPFNAM=$P(RMPFNAM,",",2)_" "_$P(RMPFNAM,",",1)
W !?3,$E(RMPFNAM,1,32),?38,"|",?44,RMPFF
F I=1:1:4 I $D(@("RMPF"_AD_"(I)"))!$D(RMPFF(I+1)) W ! W:$D(@("RMPF"_AD_"(I)")) ?3,$E(@("RMPF"_AD_"(I)"),1,32) W ?38,"|" W:$D(RMPFF(I+1)) ?44,$E(RMPFF(I+1),1,36)
D LINE
D CONT^RMPFQP2 Q:$D(RMPFOUT) D LINE:IOST?1"C-".E
W !,"5. Soc. Security No.",?20,"| 6. VA Claim No.",?38,"| 7. Date of Birth",?59,"| 8. Disability Code"
W !?20,"|",?38,"|",?59,"|"
W !?3,RMPFSSN,?20,"|",?25,RMPFCL,?38,"|",?43,RMPFDOB,?59,"|"
W ?64,RMPFDC
D LINE
Q
LINE W !,"--------------------------------------------------------------------------------"
Q
HEAD W:$Y>0 @IOF W !?25,"DEPARTMENT OF VETERANS AFFAIRS"
W !?21,"AUDIOLOGICAL SERVICES ACKNOWLEDGEMENT"
D LINE Q
HEAD1 W:$D(RMPFSTP) !,"Order Status: *** ",RMPFSTP," ***"
W ?59,"Printed: ",RMPFDAT
D LINE Q
ELG S RMPFF="" Q:'$D(RMPFX) S X=$P($G(^RMPF(791810,RMPFX,2)),U,2)
I X,$D(^RMPF(791810.4,X,0)) S RMPFF=$P(^(0),U,1)
Q
CONT Q:IOST'["P-"
D HEAD,HEAD1 W !!,"cont." D LINE Q
READ K RMPFOUT,RMPFQUT
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
I Y?1"^".E S (RMPFOUT,Y)="" Q
S:Y?1"?".E (RMPFQUT,Y)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFQP3 4429 printed Nov 22, 2024@17:46:51 Page 2
RMPFQP3 ;DDC/KAW-PRINT VA FORM 10-2477a [ 03/12/98 7:46 AM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**10**;;JUN 16, 1995
+2 ; input: RMPFX
+3 ;output: None
+4 FOR KX=1:1:RMPFCNT
DO PRINT
+5 GOTO END
PRINT if '$DATA(RMPFX)
QUIT
if 'RMPFX
QUIT
if '$DATA(^RMPF(791810,RMPFX,0))
QUIT
SET RMPFTYP=$PIECE(^(0),U,2)
+1 DO ^RMPFQP1
SET DFN=$PIECE(^RMPF(791810,RMPFX,0),U,4)
+2 DO ^RMPFDT5
DO ^RMPFDD2
DO HEAD
DO HEAD1
DO ELG
DO P1
if $DATA(RMPFOUT)
GOTO END
+3 WRITE !,"9. Currently Authorized Hearing Aid(s)"
+4 SET X=$ORDER(^RMPF(791810,RMPFX,301,0))
IF X
IF $DATA(^(X,0))
SET Y=$PIECE(^(0),U,8)
IF Y
DO DD^%DT
WRITE " as of: ",Y
+5 DO LINE
+6 WRITE !?2,"Manfacturer",?16,"|",?22,"Model",?32,"|",?34,"Serial Number",?48,"|",?50,"Furnished By",?64,"|",?67,"Date Issued"
+7 DO LINE
+8 IF $DATA(^RMPF(791810,RMPFX,301,0))
DO AUTH^RMPFQP4
GOTO NEXT
+9 FOR I=1:1:4
WRITE !,?16,"|",?32,"|",?48,"|",?64,"|"
DO LINE
NEXT IF $Y>19
DO CONT^RMPFQP2
+1 WRITE !,"10. Clinic Action Taken __ VETERAN DOES NOT REQUIRE NEW HEARING AID"
+2 WRITE !?27,"__ VETERAN DOES NOT REQUIRE HEARING AID"
+3 WRITE !?27,"__ ITEM(S) LISTED BELOW WERE ISSUED TO VETERAN"
+4 DO LINE
+5 DO CONT^RMPFQP2
if $DATA(RMPFOUT)
GOTO END
if IOST?1"C-".E
DO LINE
CLINIC WRITE !,?16,"|",?27,"|",?44,"|",?57,"| Battery",?67,"| Serial No."
+1 WRITE !,"Natl. Stock No.",?16,"|",?20,"Make",?27,"|",?33,"Model"
+2 WRITE ?44,"| Serial No.",?57,"| Type",?67,"| Replaced"
+3 DO LINE
+4 DO MOD^RMPFQP1
+5 DO CONT^RMPFQP2
if $DATA(RMPFOUT)
GOTO END
if IOST?1"C-".E
DO LINE
+6 IF $Y>58
DO CONT
+7 WRITE !,"11. Type of Fitting",?28,":",?32,RMPFTF
+8 DO LINE
+9 IF $Y>58
DO CONT
+10 IF RMPFTYP=11
SET RMPFUS="*** LOANER AID ***"
+11 WRITE !,"12. Authorized Usage of Aids:",?32,RMPFUS
+12 DO LINE
+13 IF $Y>58
DO CONT
+14 WRITE !,"13. Issued aids to be replaced to clinic stock by DDC:",?56
+15 IF RMPFHAT="S"
WRITE RMPFDDC
+16 IF '$TEST
WRITE "N/A"
+17 DO LINE
+18 IF $Y>58
DO CONT
+19 WRITE !,"14. Signature of Issuing Audiologist",?38,"|",?49,"Title",?65,"|15. Order Date"
+20 WRITE !?38,"|",?65,"|"
+21 IF $DATA(RMPFX)
DO ARRAY^RMPFDT2
SET X=0
FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
IF $DATA(^RMPF(791810,RMPFX,101,X,90))
IF $PIECE(^(90),U,12)
SET Y=$PIECE(^(90),U,12)
IF Y
IF $DATA(^VA(200,Y,0))
SET RMPFADP=$PIECE(^(0),U,1)
SET RMPFAD=Y
+22 SET T="Audiologist"
IF RMPFAD
IF $DATA(^VA(200,RMPFAD,0))
SET X=$PIECE(^(0),U,9)
IF X
IF $DATA(^DIC(3.1,X,0))
SET T=$PIECE(^(0),U,1)
+23 SET T=$EXTRACT(T,1,26)
SET L=$LENGTH(T)
+24 WRITE !?4,$PIECE(RMPFADP,",",2)_" "_$PIECE(RMPFADP,",",1),?38,"|",?39+((26-L)\2),T,?65,"|",?68,RMPFODP
+25 DO LINE
+26 IF $Y>58
DO CONT
+27 WRITE !,"16. I certify that I have",?37,"Signature of Veteran",?65,"|17. Date"
+28 WRITE !?4,"received the item(s)",?65,"|"
+29 WRITE !?4,"listed under 10 above ->",?65,"|"
+30 DO LINE
+31 WRITE !,"VA Form 10-2477a"
+32 WRITE !,"SEP 1991"
+33 DO CONT^RMPFQP2
IF IOST?1"P-".E
WRITE @IOF
+34 if $DATA(IO("S"))
DO ^%ZISC
END DO KIL^RMPFQP4
QUIT
P1 SET AD="A"
if '$DATA(RMPFX)
GOTO P2
+1 IF $DATA(^RMPF(791810,RMPFX,1))
SET S1=^(1)
IF $PIECE(S1,U,5)'=""&($PIECE(S1,U,6)'="")
Begin DoDot:1
+2 SET C=1
KILL RMPFA
+3 FOR I=1:1:3
IF $PIECE(S1,U,I)'=""
SET RMPFA(C)=$PIECE(S1,U,I)
SET C=C+1
+4 SET RMPFA(C)=$PIECE(S1,U,4)_", "_$PIECE(^DIC(5,$PIECE(S1,U,5),0),U,2)_" "_$PIECE(S1,U,6)
+5 QUIT
End DoDot:1
GOTO P3
P2 if $DATA(RMPFT)
SET AD="T"
P3 WRITE !,"1. Extended Audiology Clinic",?38,"| 2. Issuing Audiology Clinic"
+1 WRITE !?3,"Station No. ",RMPFRSTA,?38,"|",?44,"Station No. ",RMPFSTAP
+2 WRITE !?38,"|"
+3 FOR I=1:1:4
WRITE !
if $DATA(RMPFR(I))
WRITE ?3,$EXTRACT(RMPFR(I),1,35)
WRITE ?38,"|"
if $DATA(RMPFS(I))
WRITE ?44,$EXTRACT(RMPFS(I),1,36)
+4 DO LINE
+5 WRITE !,"3. Veteran's Name and Address ",?38,"| 4. Eligibility Status(es) ",?71,$JUSTIFY($EXTRACT(RMPFELS,1,9),9)
+6 WRITE !,?38,"|"
IF RMPFELD
WRITE ?70,$EXTRACT(RMPFELD,4,5)_"-"_$EXTRACT(RMPFELD,6,7)_"-"_($EXTRACT(RMPFELD,1,3)+1700)
+7 SET RMPFNAM=$PIECE(RMPFNAM,",",2)_" "_$PIECE(RMPFNAM,",",1)
+8 WRITE !?3,$EXTRACT(RMPFNAM,1,32),?38,"|",?44,RMPFF
+9 FOR I=1:1:4
IF $DATA(@("RMPF"_AD_"(I)"))!$DATA(RMPFF(I+1))
WRITE !
if $DATA(@("RMPF"_AD_"(I)"))
WRITE ?3,$EXTRACT(@("RMPF"_AD_"(I)"),1,32)
WRITE ?38,"|"
if $DATA(RMPFF(I+1))
WRITE ?44,$EXTRACT(RMPFF(I+1),1,36)
+10 DO LINE
+11 DO CONT^RMPFQP2
if $DATA(RMPFOUT)
QUIT
if IOST?1"C-".E
DO LINE
+12 WRITE !,"5. Soc. Security No.",?20,"| 6. VA Claim No.",?38,"| 7. Date of Birth",?59,"| 8. Disability Code"
+13 WRITE !?20,"|",?38,"|",?59,"|"
+14 WRITE !?3,RMPFSSN,?20,"|",?25,RMPFCL,?38,"|",?43,RMPFDOB,?59,"|"
+15 WRITE ?64,RMPFDC
+16 DO LINE
+17 QUIT
LINE WRITE !,"--------------------------------------------------------------------------------"
+1 QUIT
HEAD if $Y>0
WRITE @IOF
WRITE !?25,"DEPARTMENT OF VETERANS AFFAIRS"
+1 WRITE !?21,"AUDIOLOGICAL SERVICES ACKNOWLEDGEMENT"
+2 DO LINE
QUIT
HEAD1 if $DATA(RMPFSTP)
WRITE !,"Order Status: *** ",RMPFSTP," ***"
+1 WRITE ?59,"Printed: ",RMPFDAT
+2 DO LINE
QUIT
ELG SET RMPFF=""
if '$DATA(RMPFX)
QUIT
SET X=$PIECE($GET(^RMPF(791810,RMPFX,2)),U,2)
+1 IF X
IF $DATA(^RMPF(791810.4,X,0))
SET RMPFF=$PIECE(^(0),U,1)
+2 QUIT
CONT if IOST'["P-"
QUIT
+1 DO HEAD
DO HEAD1
WRITE !!,"cont."
DO LINE
QUIT
READ KILL RMPFOUT,RMPFQUT
+1 READ Y:DTIME
IF '$TEST
WRITE $CHAR(7)
READ Y:5
if Y="."
GOTO READ
if '$TEST
SET Y=U
+2 IF Y?1"^".E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
