GMTSMCPS ; WISC/DCB - Medicine 2.2 Health Summary Component ; 08/27/2002
;;2.7;Health Summary;**16,56**;Oct 20, 1995
;
; External References
; DBIA 10061 KVAR^VADPT
; DBIA 80 ^MCAR(690
; DBIA 10011 ^DIWP
;
BEG ; One Line summary only
D START(0,"B") Q
BRIEF ; Brief Summary
D START(1,"B") Q
ABN ; Print Brief summary for only abnormal or Null
D START(2,"B") Q
FULL ; Full Summary
D START(1,"F") Q
CAP ; Capture
D START(1,"C") Q
ADBF ; Print Full Summary for only abnormal or null
D START(2,"F") Q
;
START(BRIEF,MCTYPE) ; Get the record and display the record
N TV,VV,SP,MAX
K ^TMP("MCAR",$J)
S RMAR=$S($D(IOM):IOM,1:IOM)
S TV=(.25*RMAR+.5)\1
S VV=(.70*RMAR+.5)\1
S SP=(RMAR-(TV+VV))-1
D KVAR^VADPT
I '$D(^MCAR(690,"AC",DFN)) D EXIT Q
D SEARCH
I '$D(^TMP("MCAR",$J)) D EXIT Q
F MCL=1:1 Q:$D(GMTSQIT) Q:'$D(^TMP("MCAR",$J,MCL)) D GETREC(MCL,RMAR,TV,VV,SP)
D EXIT
Q
SEARCH ; Search for Selected Patient
S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
D HSUM^GMTSMCMA(DFN,GMTSEND,GMTSBEG,MAX,"",MCTYPE)
Q
GETREC(MCL,RMAR,TV,VV,SP) ; Return Single Record
N MCDATE,MCPROC,MCSUM,MCPSUM,LOOP,LINE,BLINE
S (LOOP,BLINE)="",$P(BLINE,"-",80)="-"
S MCDATE=$$RETURN("DATE/TIME",MCL)
S MCPROC=$$RETURN("PROCEDURE",MCL)
S MCSUM=$$RETURN("SUMMARY",MCL)
I BRIEF=2,("NBT"[$E(MCSUM,1)),(MCSUM'="") Q
S MCPSUM=$$RETURN("PROCEDURE SUMMARY",MCL)
D CKP^GMTSUP Q:$D(GMTSQIT) W !,MCDATE,?(TV+SP),MCPROC
D CKP^GMTSUP Q:$D(GMTSQIT) W !,BLINE
D:MCSUM'="" PRINT(MCSUM,VV,"Summary:",TV,SP)
D:MCPSUM'="" PRINT(MCPSUM,VV,"Procedure Summary:",TV,SP)
D CKP^GMTSUP Q:$D(GMTSQIT) W !
Q:+$G(BRIEF)=0
F S LOOP=+$O(^TMP("MCAR",$J,MCL,LOOP)) Q:LOOP=0!$D(GMTSQIT) D REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP)
Q
REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP) ; Report for Procedure
N LINE,TEMP,HOLD,TITLE,VALUE,UNITS,MLEN,RANGE
N TARRAY,VARRY,LARRAY,TMAX,VMAX,MAX,LOOP2
S LINE=^TMP("MCAR",$J,MCL,LOOP,1)
S TEMP=$P(LINE,U,1),TITLE=$P(TEMP,";",1)_":"
S VALUE=$P(LINE,U,3,255),UNITS=$P(LINE,U,2)
Q:(VALUE="")&(MCTYPE="C")
I $P(TEMP,";",2)="W" D WORD(MCL,LOOP,TITLE,RMAR,TV,VV,SP) Q
S VALUE=VALUE_$S(UNITS="":"",1:" "_UNITS)
D PRINT(VALUE,VV,TITLE,TV,SP)
D CKP^GMTSUP Q:$D(GMTSQIT) W !
Q
WARP(VALUE,LENGTH,TEMP,MAX) ; Warp a field
N DIWL,DIWR,DIWF,X,LOOP3,TEMP1 S LOOP3=""
K ^UTILITY($J,"W")
S DIWL=0,DIWR=LENGTH,X=VALUE D ^DIWP
F MAX=1:1 S LOOP3=+$O(^UTILITY($J,"W",DIWL,LOOP3)) Q:LOOP3=0 D
. S TEMP1=^UTILITY($J,"W",DIWL,LOOP3,0)
. S:$E(TEMP1,$L(TEMP1))=" " TEMP1=$E(TEMP1,1,$L(TEMP1)-1)
. S TEMP(LOOP3)=TEMP1
S MAX=MAX-1
Q
WORD(MCL,LOOP,TITLE,RMAR,TV,VV,SP) ; Display Word Processing
N SLOOP,X,DIWR,DIWL,DIWF,TARRAY,TMAX,LOOP3,SPAC
D WARP(TITLE,TV,.TARRAY,.TMAX) K ^UTILITY($J,"W") S DIWR=VV,DIWL=0
F SLOOP=0:0 S SLOOP=+$O(^TMP("MCAR",$J,MCL,LOOP,SLOOP)) Q:SLOOP=0 D
. S X=$P(^TMP("MCAR",$J,MCL,LOOP,SLOOP),U,3) D ^DIWP
S SLOOP=0
F LOOP3=1:1 S SLOOP=+$O(^UTILITY($J,"W",DIWL,SLOOP)) Q:(SLOOP=0)!($D(GMTSQIT)) D
. D CKP^GMTSUP Q:$D(GMTSQIT)
. W !,$J($G(TARRAY(LOOP3)),TV),?(TV+SP),^UTILITY($J,"W",DIWL,SLOOP,0)
D CKP^GMTSUP Q:$D(GMTSQIT) W !
Q
CONVERT(TITLE) ; Convert to Mixed Case TEMP = Temp
N UPPER,LOWER,TEMP,LOOP,HOLD,HOLD2
S UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ",LOWER="abcdefghijklmnopqrstuvwxyz"
F LOOP=1:1:255 S HOLD=$P(TITLE," ",LOOP) Q:HOLD="" D
. S:$D(TEMP) TEMP=TEMP_" "
. S HOLD2=$E(HOLD,2,$L(HOLD))
. S TEMP=$G(TEMP)_$E(HOLD,1)_$TR(HOLD2,UPPER,LOWER)
Q TEMP
PRINT(VALUE,VV,TITLE,TV,SP) ; Print a Field and its Value
N VMAX,TMAX,TARRAY,VARRAY,SPAC,LOOP2
S TITLE=$$CONVERT(TITLE)
D WARP(VALUE,VV,.VARRAY,.VMAX)
D WARP(TITLE,TV,.TARRAY,.TMAX)
S MAX=$S(VMAX<TMAX:TMAX,VMAX>TMAX:VMAX,1:TMAX)
S SPAC=TMAX-VMAX S SPAC=$S(SPAC'>0:0,1:SPAC)
F LOOP2=1:1:MAX D CKP^GMTSUP Q:$D(GMTSQIT) D
. W !,$J($G(TARRAY(LOOP2)),TV),?(TV+SP),$G(VARRAY(LOOP2-SPAC))
Q:$D(GMTSQIT)
Q
RETURN(TYPE,LINE) ; Return key Elements
N MCHOLD,HOLD
S MCHOLD=+$O(^TMP("MCAR",$J,LINE,"B",TYPE,""))
S HOLD=$P($G(^TMP("MCAR",$J,LINE,MCHOLD,1)),U,3)
K ^TMP("MCAR",$J,LINE,"B",TYPE,LINE)
K ^TMP("MCAR",$J,LINE,MCHOLD,1)
Q HOLD
EXIT ; Clean up and Quit
K PR,OT,DA,MCARPPS,MCI,MCJ,R,MCL,S1,S2,S4,S5,S6,LL,LL1,MAX,VA
K ^TMP("MCAR",$J),K,N,MCARDT,MCARNM,MCARPROC,M,RMAR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSMCPS 4356 printed Sep 23, 2025@19:34:11 Page 2
GMTSMCPS ; WISC/DCB - Medicine 2.2 Health Summary Component ; 08/27/2002
+1 ;;2.7;Health Summary;**16,56**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10061 KVAR^VADPT
+5 ; DBIA 80 ^MCAR(690
+6 ; DBIA 10011 ^DIWP
+7 ;
BEG ; One Line summary only
+1 DO START(0,"B")
QUIT
BRIEF ; Brief Summary
+1 DO START(1,"B")
QUIT
ABN ; Print Brief summary for only abnormal or Null
+1 DO START(2,"B")
QUIT
FULL ; Full Summary
+1 DO START(1,"F")
QUIT
CAP ; Capture
+1 DO START(1,"C")
QUIT
ADBF ; Print Full Summary for only abnormal or null
+1 DO START(2,"F")
QUIT
+2 ;
START(BRIEF,MCTYPE) ; Get the record and display the record
+1 NEW TV,VV,SP,MAX
+2 KILL ^TMP("MCAR",$JOB)
+3 SET RMAR=$SELECT($DATA(IOM):IOM,1:IOM)
+4 SET TV=(.25*RMAR+.5)\1
+5 SET VV=(.70*RMAR+.5)\1
+6 SET SP=(RMAR-(TV+VV))-1
+7 DO KVAR^VADPT
+8 IF '$DATA(^MCAR(690,"AC",DFN))
DO EXIT
QUIT
+9 DO SEARCH
+10 IF '$DATA(^TMP("MCAR",$JOB))
DO EXIT
QUIT
+11 FOR MCL=1:1
if $DATA(GMTSQIT)
QUIT
if '$DATA(^TMP("MCAR",$JOB,MCL))
QUIT
DO GETREC(MCL,RMAR,TV,VV,SP)
+12 DO EXIT
+13 QUIT
SEARCH ; Search for Selected Patient
+1 SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:99999)
+2 DO HSUM^GMTSMCMA(DFN,GMTSEND,GMTSBEG,MAX,"",MCTYPE)
+3 QUIT
GETREC(MCL,RMAR,TV,VV,SP) ; Return Single Record
+1 NEW MCDATE,MCPROC,MCSUM,MCPSUM,LOOP,LINE,BLINE
+2 SET (LOOP,BLINE)=""
SET $PIECE(BLINE,"-",80)="-"
+3 SET MCDATE=$$RETURN("DATE/TIME",MCL)
+4 SET MCPROC=$$RETURN("PROCEDURE",MCL)
+5 SET MCSUM=$$RETURN("SUMMARY",MCL)
+6 IF BRIEF=2
IF ("NBT"[$EXTRACT(MCSUM,1))
IF (MCSUM'="")
QUIT
+7 SET MCPSUM=$$RETURN("PROCEDURE SUMMARY",MCL)
+8 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,MCDATE,?(TV+SP),MCPROC
+9 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,BLINE
+10 if MCSUM'=""
DO PRINT(MCSUM,VV,"Summary:",TV,SP)
+11 if MCPSUM'=""
DO PRINT(MCPSUM,VV,"Procedure Summary:",TV,SP)
+12 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
+13 if +$GET(BRIEF)=0
QUIT
+14 FOR
SET LOOP=+$ORDER(^TMP("MCAR",$JOB,MCL,LOOP))
if LOOP=0!$DATA(GMTSQIT)
QUIT
DO REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP)
+15 QUIT
REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP) ; Report for Procedure
+1 NEW LINE,TEMP,HOLD,TITLE,VALUE,UNITS,MLEN,RANGE
+2 NEW TARRAY,VARRY,LARRAY,TMAX,VMAX,MAX,LOOP2
+3 SET LINE=^TMP("MCAR",$JOB,MCL,LOOP,1)
+4 SET TEMP=$PIECE(LINE,U,1)
SET TITLE=$PIECE(TEMP,";",1)_":"
+5 SET VALUE=$PIECE(LINE,U,3,255)
SET UNITS=$PIECE(LINE,U,2)
+6 if (VALUE="")&(MCTYPE="C")
QUIT
+7 IF $PIECE(TEMP,";",2)="W"
DO WORD(MCL,LOOP,TITLE,RMAR,TV,VV,SP)
QUIT
+8 SET VALUE=VALUE_$SELECT(UNITS="":"",1:" "_UNITS)
+9 DO PRINT(VALUE,VV,TITLE,TV,SP)
+10 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
+11 QUIT
WARP(VALUE,LENGTH,TEMP,MAX) ; Warp a field
+1 NEW DIWL,DIWR,DIWF,X,LOOP3,TEMP1
SET LOOP3=""
+2 KILL ^UTILITY($JOB,"W")
+3 SET DIWL=0
SET DIWR=LENGTH
SET X=VALUE
DO ^DIWP
+4 FOR MAX=1:1
SET LOOP3=+$ORDER(^UTILITY($JOB,"W",DIWL,LOOP3))
if LOOP3=0
QUIT
Begin DoDot:1
+5 SET TEMP1=^UTILITY($JOB,"W",DIWL,LOOP3,0)
+6 if $EXTRACT(TEMP1,$LENGTH(TEMP1))=" "
SET TEMP1=$EXTRACT(TEMP1,1,$LENGTH(TEMP1)-1)
+7 SET TEMP(LOOP3)=TEMP1
End DoDot:1
+8 SET MAX=MAX-1
+9 QUIT
WORD(MCL,LOOP,TITLE,RMAR,TV,VV,SP) ; Display Word Processing
+1 NEW SLOOP,X,DIWR,DIWL,DIWF,TARRAY,TMAX,LOOP3,SPAC
+2 DO WARP(TITLE,TV,.TARRAY,.TMAX)
KILL ^UTILITY($JOB,"W")
SET DIWR=VV
SET DIWL=0
+3 FOR SLOOP=0:0
SET SLOOP=+$ORDER(^TMP("MCAR",$JOB,MCL,LOOP,SLOOP))
if SLOOP=0
QUIT
Begin DoDot:1
+4 SET X=$PIECE(^TMP("MCAR",$JOB,MCL,LOOP,SLOOP),U,3)
DO ^DIWP
End DoDot:1
+5 SET SLOOP=0
+6 FOR LOOP3=1:1
SET SLOOP=+$ORDER(^UTILITY($JOB,"W",DIWL,SLOOP))
if (SLOOP=0)!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+7 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+8 WRITE !,$JUSTIFY($GET(TARRAY(LOOP3)),TV),?(TV+SP),^UTILITY($JOB,"W",DIWL,SLOOP,0)
End DoDot:1
+9 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
+10 QUIT
CONVERT(TITLE) ; Convert to Mixed Case TEMP = Temp
+1 NEW UPPER,LOWER,TEMP,LOOP,HOLD,HOLD2
+2 SET UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
SET LOWER="abcdefghijklmnopqrstuvwxyz"
+3 FOR LOOP=1:1:255
SET HOLD=$PIECE(TITLE," ",LOOP)
if HOLD=""
QUIT
Begin DoDot:1
+4 if $DATA(TEMP)
SET TEMP=TEMP_" "
+5 SET HOLD2=$EXTRACT(HOLD,2,$LENGTH(HOLD))
+6 SET TEMP=$GET(TEMP)_$EXTRACT(HOLD,1)_$TRANSLATE(HOLD2,UPPER,LOWER)
End DoDot:1
+7 QUIT TEMP
PRINT(VALUE,VV,TITLE,TV,SP) ; Print a Field and its Value
+1 NEW VMAX,TMAX,TARRAY,VARRAY,SPAC,LOOP2
+2 SET TITLE=$$CONVERT(TITLE)
+3 DO WARP(VALUE,VV,.VARRAY,.VMAX)
+4 DO WARP(TITLE,TV,.TARRAY,.TMAX)
+5 SET MAX=$SELECT(VMAX<TMAX:TMAX,VMAX>TMAX:VMAX,1:TMAX)
+6 SET SPAC=TMAX-VMAX
SET SPAC=$SELECT(SPAC'>0:0,1:SPAC)
+7 FOR LOOP2=1:1:MAX
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
Begin DoDot:1
+8 WRITE !,$JUSTIFY($GET(TARRAY(LOOP2)),TV),?(TV+SP),$GET(VARRAY(LOOP2-SPAC))
End DoDot:1
+9 if $DATA(GMTSQIT)
QUIT
+10 QUIT
RETURN(TYPE,LINE) ; Return key Elements
+1 NEW MCHOLD,HOLD
+2 SET MCHOLD=+$ORDER(^TMP("MCAR",$JOB,LINE,"B",TYPE,""))
+3 SET HOLD=$PIECE($GET(^TMP("MCAR",$JOB,LINE,MCHOLD,1)),U,3)
+4 KILL ^TMP("MCAR",$JOB,LINE,"B",TYPE,LINE)
+5 KILL ^TMP("MCAR",$JOB,LINE,MCHOLD,1)
+6 QUIT HOLD
EXIT ; Clean up and Quit
+1 KILL PR,OT,DA,MCARPPS,MCI,MCJ,R,MCL,S1,S2,S4,S5,S6,LL,LL1,MAX,VA
+2 KILL ^TMP("MCAR",$JOB),K,N,MCARDT,MCARNM,MCARPROC,M,RMAR
+3 QUIT
