source: FOIAVistA/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNFPLT1.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1SPNFPLT1 ;HISC/DAD-FIM SCORE REPORT ;10/18/01 10:41
2 ;;2.0;Spinal Cord Dysfunction;**3,6,16**;01/02/1997
3PRINT ;
4 S SPNTODAY=$$FMTE^XLFDT(DT),SPNEXIT=0,SPNFPAGE(0)=1
5 K SPNFUNDL S $P(SPNFUNDL,"-",81)=""
6 ; I +SPNFSTYP=1 S SPNFHI=91,SPNFLO=13
7 ; I +SPNFSTYP=2 S SPNFHI=35,SPNFLO=5
8 ; I +SPNFSTYP=3 S SPNFHI=$S(+SPNFFTYP=1:52,1:126),SPNFLO=$S(+SPNFFTYP=1:13,1:18)
9 U IO
10 S SPNFDFN(0)=""
11 F S SPNFDFN(0)=$O(^TMP($J,"SPNFPLT0",SPNFDFN(0))) Q:SPNFDFN(0)=""!SPNEXIT D
12 . S SPNFDFN=0
13 . F S SPNFDFN=$O(^TMP($J,"SPNFPLT0",SPNFDFN(0),SPNFDFN)) Q:SPNFDFN'>0!SPNEXIT D DFN
14 Q
15 ;
16DFN ;
17 S SPNFDFN(1)=$P($G(^SPNL(154.1,SPNFDFN,0)),U)
18 S SPNFDFN(154)=$$GET1^DIQ(154.1,SPNFDFN,.01,"I")
19 S SPNFPAGE=1,SPNFOUND=0
20 S DIC="^SPNL(154.1," K SPNFDATA
21 F DR=999.01,999.02,999.03,999.04,999.05 D
22 . S DIQ="SPNFDATA(",DIQ(0)="E",DA=SPNFDFN
23 . D EN^DIQ1
24 . S:'$D(SPNFDATA(154.1,SPNFDFN,DR,"E")) SPNFDATA(154,SPNFDFN(1),DR,"E")="UNKNOWN"
25 D HEAD
26 S SPNFDATE=SPNFBDT-.0000001
27 F S SPNFDATE=$O(^SPNL(154.1,"AA",+SPNFFTYP,SPNFDFN(1),SPNFDATE)) Q:(SPNFDATE'>0)!(SPNFDATE>(SPNFEDT+.9))!SPNEXIT D
28 . S SPNFD0=0
29 . F S SPNFD0=$O(^SPNL(154.1,"AA",+SPNFFTYP,SPNFDFN(1),SPNFDATE,SPNFD0)) Q:SPNFD0'>0!SPNEXIT D LINE
30 . Q
31 I SPNFOUND'>0 W !!,"No data found for this patient"
32 D FOOT,PAUSE:'SPNEXIT
33 Q
34LINE ;
35 S SPNSCORE=-1
36 I +SPNFSTYP=1 S SPNSCORE=$$EN1^SPNFUTL0(SPNFD0)
37 I +SPNFSTYP=2 S SPNSCORE=$$EN2^SPNFUTL0(SPNFD0)
38 I +SPNFSTYP=3 S SPNSCORE=$$EN3^SPNFUTL0(SPNFD0)
39 I SPNSCORE<0 Q
40 ; W !?18,$TR($J("",SPNSCORE-SPNFLO+1*(62/(SPNFHI-SPNFLO+1)))," ","*")
41 S SPNSCORE(0)=$S(SPNSCORE:$J(+SPNSCORE,6,1),1:$J(SPNSCORE,6))
42 S SPNSCORE(0)=SPNSCORE(0)_$S(SPNSCORE["*":"*",1:"")
43 S SPNFOUND=1
44 ;**MOD,SD/AB,1/27/98, Commented out next line, replaced /w line that follows
45 S SPNFDATE(0)=$E(SPNFDATE,4,5)_"/"_$E(SPNFDATE,6,7)_"/"_$E(SPNFDATE,2,3)
46 ;S SPNFDATE(0)=$$DATEFMT^SPNLRUDT(SPNFDATE,4)
47 W !,SPNFDATE(0),?9,SPNSCORE(0)
48 S SPNFDATA=$P($G(^SPNL(154.1,SPNFD0,0)),U,5,22)
49 I (+SPNFFTYP=1)!(+SPNFSTYP=1) S $P(SPNFDATA,U,14,18)="^^^^"
50 I +SPNFSTYP=2 S $P(SPNFDATA,U,1,13)="^^^^^^^^^^^^"
51 S SPNFTAB=20
52 F SPNPIECE=1:1:18 D
53 . S SPNFLEVL=+$P(SPNFDATA,U,SPNPIECE)
54 . I SPNFLEVL W ?SPNFTAB,$P($G(^SPNL(154.11,SPNFLEVL,0)),U)
55 . S SPNFTAB=SPNFTAB+3
56 . Q
57 I $Y>(IOSL-6) D PAUSE,HEAD
58 Q
59PAUSE ;
60 I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S SPNEXIT=$S(Y'>0:1,1:0)
61 Q
62HEAD ;
63 I SPNEXIT Q
64 W:($E(IOST)="C")!(SPNFPAGE(0)>1) @IOF
65 S SPNFPAGE(0)=SPNFPAGE(0)+1
66 S X=$P(SPNFFTYP,U,2)_" "_$P(SPNFSTYP,U,2)
67 W !?80-$L(X)/2,X,?68,"Page: ",SPNFPAGE S SPNFPAGE=SPNFPAGE+1
68 S X="for "_SPNFDFN(0)
69 W !?80-$L(X)/2,X,?68,SPNTODAY
70 S X="SSN: "_SPNFDATA(154.1,SPNFDFN,999.01,"E")
71 S X=X_", DOB: "_SPNFDATA(154.1,SPNFDFN,999.02,"E")
72 W !?80-$L(X)/2,X
73 S X="Extent & Completeness: "_$$GET1^DIQ(154,SPNFDFN(154),999.04,"E")
74 S X=X_" - "_$$GET1^DIQ(154,SPNFDFN(154),999.03,"E")
75 W !?80-$L(X)/2,X
76 S X="Type of Injury: "_$$GET1^DIQ(154,SPNFDFN(154),999.05,"E")
77 W !?80-$L(X)/2,X
78 W !!,"DATE",?10,"SCORE"
79 S SPNFTAB=20
80 F SPNPIECE=1:1:$S($P(SPNFFTYP,U,1)=1:13,1:18) W ?SPNFTAB,$C(64+SPNPIECE) S SPNFTAB=SPNFTAB+3
81 W !,SPNFUNDL,!
82 Q
83FOOT ;
84 ;-- Check to see if enough room at page bottom to write footer information
85 I $Y>(IOSL-8) D PAUSE,HEAD
86 ;-- Next write blank linefeeds until 8 lines up from the bottom og page
87 F W ! Q:$Y=(IOSL-8)
88 ;-- Now write footer information
89 W !,"A-EATING G-BLADDER MANAGEMENT M-STAIRS"
90 I $P(SPNFFTYP,U,1)=2 W !,"B-GROOMING H-BOWEL MANAGEMENT N-COMPREHENSION"
91 E W !,"B-GROOMING H-BOWEL MANAGEMENT"
92 I $P(SPNFFTYP,U,1)=2 W !,"C-BATHING I-TRANSFER TO BED/CHAIR O-EXPRESSION"
93 E W !,"C-BATHING I-TRANSFER TO BED/CHAIR"
94 I $P(SPNFFTYP,U,1)=2 W !,"D-DRESSING UPPER BODY J-TRANSFER TO TOILET P-SOCIAL INTERACTION"
95 E W !,"D-DRESSING UPPER BODY J-TRANSFER TO TOILET"
96 I $P(SPNFFTYP,U,1)=2 W !,"E-DRESSING LOWER BODY K-TRANSFER TO TUB/SHOWER Q-PROBLEM SOLVING"
97 E W !,"E-DRESSING LOWER BODY K-TRANSFER TO TUB/SHOWER"
98 I $P(SPNFFTYP,U,1)=2 W !,"F-TOILETING L-MOVE AROUND INSIDE YOUR HOUSE R-MEMORY"
99 E W !,"F-TOILETING L-MOVE AROUND INSIDE YOUR HOUSE"
100 W !," Star ""*"" indicates the score is incomplete."
101 Q
Note: See TracBrowser for help on using the repository browser.