source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSMCPS.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1GMTSMCPS ; WISC/DCB - Medicine 2.2 Health Summary Component ; 08/27/2002
2 ;;2.7;Health Summary;**16,56**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10061 KVAR^VADPT
6 ; DBIA 80 ^MCAR(690
7 ; DBIA 10011 ^DIWP
8 ;
9BEG ; One Line summary only
10 D START(0,"B") Q
11BRIEF ; Brief Summary
12 D START(1,"B") Q
13ABN ; Print Brief summary for only abnormal or Null
14 D START(2,"B") Q
15FULL ; Full Summary
16 D START(1,"F") Q
17CAP ; Capture
18 D START(1,"C") Q
19ADBF ; Print Full Summary for only abnormal or null
20 D START(2,"F") Q
21 ;
22START(BRIEF,MCTYPE) ; Get the record and display the record
23 N TV,VV,SP,MAX
24 K ^TMP("MCAR",$J)
25 S RMAR=$S($D(IOM):IOM,1:IOM)
26 S TV=(.25*RMAR+.5)\1
27 S VV=(.70*RMAR+.5)\1
28 S SP=(RMAR-(TV+VV))-1
29 D KVAR^VADPT
30 I '$D(^MCAR(690,"AC",DFN)) D EXIT Q
31 D SEARCH
32 I '$D(^TMP("MCAR",$J)) D EXIT Q
33 F MCL=1:1 Q:$D(GMTSQIT) Q:'$D(^TMP("MCAR",$J,MCL)) D GETREC(MCL,RMAR,TV,VV,SP)
34 D EXIT
35 Q
36SEARCH ; Search for Selected Patient
37 S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
38 D HSUM^GMTSMCMA(DFN,GMTSEND,GMTSBEG,MAX,"",MCTYPE)
39 Q
40GETREC(MCL,RMAR,TV,VV,SP) ; Return Single Record
41 N MCDATE,MCPROC,MCSUM,MCPSUM,LOOP,LINE,BLINE
42 S (LOOP,BLINE)="",$P(BLINE,"-",80)="-"
43 S MCDATE=$$RETURN("DATE/TIME",MCL)
44 S MCPROC=$$RETURN("PROCEDURE",MCL)
45 S MCSUM=$$RETURN("SUMMARY",MCL)
46 I BRIEF=2,("NBT"[$E(MCSUM,1)),(MCSUM'="") Q
47 S MCPSUM=$$RETURN("PROCEDURE SUMMARY",MCL)
48 D CKP^GMTSUP Q:$D(GMTSQIT) W !,MCDATE,?(TV+SP),MCPROC
49 D CKP^GMTSUP Q:$D(GMTSQIT) W !,BLINE
50 D:MCSUM'="" PRINT(MCSUM,VV,"Summary:",TV,SP)
51 D:MCPSUM'="" PRINT(MCPSUM,VV,"Procedure Summary:",TV,SP)
52 D CKP^GMTSUP Q:$D(GMTSQIT) W !
53 Q:+$G(BRIEF)=0
54 F S LOOP=+$O(^TMP("MCAR",$J,MCL,LOOP)) Q:LOOP=0!$D(GMTSQIT) D REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP)
55 Q
56REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP) ; Report for Procedure
57 N LINE,TEMP,HOLD,TITLE,VALUE,UNITS,MLEN,RANGE
58 N TARRAY,VARRY,LARRAY,TMAX,VMAX,MAX,LOOP2
59 S LINE=^TMP("MCAR",$J,MCL,LOOP,1)
60 S TEMP=$P(LINE,U,1),TITLE=$P(TEMP,";",1)_":"
61 S VALUE=$P(LINE,U,3,255),UNITS=$P(LINE,U,2)
62 Q:(VALUE="")&(MCTYPE="C")
63 I $P(TEMP,";",2)="W" D WORD(MCL,LOOP,TITLE,RMAR,TV,VV,SP) Q
64 S VALUE=VALUE_$S(UNITS="":"",1:" "_UNITS)
65 D PRINT(VALUE,VV,TITLE,TV,SP)
66 D CKP^GMTSUP Q:$D(GMTSQIT) W !
67 Q
68WARP(VALUE,LENGTH,TEMP,MAX) ; Warp a field
69 N DIWL,DIWR,DIWF,X,LOOP3,TEMP1 S LOOP3=""
70 K ^UTILITY($J,"W")
71 S DIWL=0,DIWR=LENGTH,X=VALUE D ^DIWP
72 F MAX=1:1 S LOOP3=+$O(^UTILITY($J,"W",DIWL,LOOP3)) Q:LOOP3=0 D
73 . S TEMP1=^UTILITY($J,"W",DIWL,LOOP3,0)
74 . S:$E(TEMP1,$L(TEMP1))=" " TEMP1=$E(TEMP1,1,$L(TEMP1)-1)
75 . S TEMP(LOOP3)=TEMP1
76 S MAX=MAX-1
77 Q
78WORD(MCL,LOOP,TITLE,RMAR,TV,VV,SP) ; Display Word Processing
79 N SLOOP,X,DIWR,DIWL,DIWF,TARRAY,TMAX,LOOP3,SPAC
80 D WARP(TITLE,TV,.TARRAY,.TMAX) K ^UTILITY($J,"W") S DIWR=VV,DIWL=0
81 F SLOOP=0:0 S SLOOP=+$O(^TMP("MCAR",$J,MCL,LOOP,SLOOP)) Q:SLOOP=0 D
82 . S X=$P(^TMP("MCAR",$J,MCL,LOOP,SLOOP),U,3) D ^DIWP
83 S SLOOP=0
84 F LOOP3=1:1 S SLOOP=+$O(^UTILITY($J,"W",DIWL,SLOOP)) Q:(SLOOP=0)!($D(GMTSQIT)) D
85 . D CKP^GMTSUP Q:$D(GMTSQIT)
86 . W !,$J($G(TARRAY(LOOP3)),TV),?(TV+SP),^UTILITY($J,"W",DIWL,SLOOP,0)
87 D CKP^GMTSUP Q:$D(GMTSQIT) W !
88 Q
89CONVERT(TITLE) ; Convert to Mixed Case TEMP = Temp
90 N UPPER,LOWER,TEMP,LOOP,HOLD,HOLD2
91 S UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ",LOWER="abcdefghijklmnopqrstuvwxyz"
92 F LOOP=1:1:255 S HOLD=$P(TITLE," ",LOOP) Q:HOLD="" D
93 . S:$D(TEMP) TEMP=TEMP_" "
94 . S HOLD2=$E(HOLD,2,$L(HOLD))
95 . S TEMP=$G(TEMP)_$E(HOLD,1)_$TR(HOLD2,UPPER,LOWER)
96 Q TEMP
97PRINT(VALUE,VV,TITLE,TV,SP) ; Print a Field and its Value
98 N VMAX,TMAX,TARRAY,VARRAY,SPAC,LOOP2
99 S TITLE=$$CONVERT(TITLE)
100 D WARP(VALUE,VV,.VARRAY,.VMAX)
101 D WARP(TITLE,TV,.TARRAY,.TMAX)
102 S MAX=$S(VMAX<TMAX:TMAX,VMAX>TMAX:VMAX,1:TMAX)
103 S SPAC=TMAX-VMAX S SPAC=$S(SPAC'>0:0,1:SPAC)
104 F LOOP2=1:1:MAX D CKP^GMTSUP Q:$D(GMTSQIT) D
105 . W !,$J($G(TARRAY(LOOP2)),TV),?(TV+SP),$G(VARRAY(LOOP2-SPAC))
106 Q:$D(GMTSQIT)
107 Q
108RETURN(TYPE,LINE) ; Return key Elements
109 N MCHOLD,HOLD
110 S MCHOLD=+$O(^TMP("MCAR",$J,LINE,"B",TYPE,""))
111 S HOLD=$P($G(^TMP("MCAR",$J,LINE,MCHOLD,1)),U,3)
112 K ^TMP("MCAR",$J,LINE,"B",TYPE,LINE)
113 K ^TMP("MCAR",$J,LINE,MCHOLD,1)
114 Q HOLD
115EXIT ; Clean up and Quit
116 K PR,OT,DA,MCARPPS,MCI,MCJ,R,MCL,S1,S2,S4,S5,S6,LL,LL1,MAX,VA
117 K ^TMP("MCAR",$J),K,N,MCARDT,MCARNM,MCARPROC,M,RMAR
118 Q
Note: See TracBrowser for help on using the repository browser.