GMTSMCZZ.m

GMTSMCZZ ;SLC/SBW - Medicine 2.2 HS Component ;18/APRIL/95

 ;;2.7;Health Summary;;Oct 20, 1995

GMTSMCPS ;WISC/DCB - Medicine 2.2 Health Summary Component ;5/10/94

 ;;2.7;Health Summary;;Oct 20, 1995

BEG ;One Line summary only

 D START(0,"B") Q

BRIEF ;Brief Summary 

 D START(1,"B") Q

ABN ;Print Brief summary for only abnomaral or Null

 D START(2,"B") Q 

FULL ;Full Sunnary

 D START(1,"F") Q

CAP ;Capture

 D START(1,"C") Q

ADBF ;Print Full Summary for only abnotmal or null

 D START(2,"F") Q

START(BRIEF,MCTYPE) ;Get the record and display the record

 N TV,VV,SP

 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

 I $D(GMTSNDM),(GMTSNDM>0) S MAX=GMTSNDM

 E  S MAX=50

 D HSUM^GMTSMCMA(DFN,GMTSEND,GMTSBEG,MAX,"",MCTYPE)

 Q

GETREC(MCL,RMAR,TV,VV,SP) ;Return 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)

 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

 I BRIEF=2,("N"[$E(MCSUM,1)),(MCSUM'="") Q

 F  S LOOP=+$O(^TMP("MCAR",$J,MCL,LOOP)) Q:LOOP=0!$D(GMTSQIT)  D REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP)

 Q

 I MLEN>RMAR D CKP^GMTSUP Q:$D(GMTSQIT)  W !

REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP) ;Report on 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 a word to upper/lower 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<0 SPAC=0

 F LOOP2=1:1:TMAX 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 ;

 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

GMTSMCZZ  ;SLC/SBW - Medicine 2.2 HS Component ;18/APRIL/95

 +1       ;;2.7;Health Summary;;Oct 20, 1995

GMTSMCPS  ;WISC/DCB - Medicine 2.2 Health Summary Component ;5/10/94

 +1       ;;2.7;Health Summary;;Oct 20, 1995

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 abnomaral or Null

 +1        DO START(2,"B")

           QUIT 

FULL      ;Full Sunnary

 +1        DO START(1,"F")

           QUIT 

CAP       ;Capture

 +1        DO START(1,"C")

           QUIT 

ADBF      ;Print Full Summary for only abnotmal or null

 +1        DO START(2,"F")

           QUIT 

START(BRIEF,MCTYPE) ;Get the record and display the record

 +1        NEW TV,VV,SP

 +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        IF $DATA(GMTSNDM)

               IF (GMTSNDM>0)

                   SET MAX=GMTSNDM

 +2       IF '$TEST

               SET MAX=50

 +3        DO HSUM^GMTSMCMA(DFN,GMTSEND,GMTSBEG,MAX,"",MCTYPE)

 +4        QUIT 

GETREC(MCL,RMAR,TV,VV,SP) ;Return 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        SET MCPSUM=$$RETURN("PROCEDURE SUMMARY",MCL)

 +7        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           WRITE !,MCDATE,?(TV+SP),MCPROC

 +8        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           WRITE !,BLINE

 +9        IF MCSUM'=""

               DO PRINT(MCSUM,VV,"Summary:",TV,SP)

 +10       IF MCPSUM'=""

               DO PRINT(MCPSUM,VV,"Procedure Summary:",TV,SP)

 +11       DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           WRITE !

 +12       IF +$GET(BRIEF)=0

               QUIT 

 +13       IF BRIEF=2

               IF ("N"[$EXTRACT(MCSUM,1))

                   IF (MCSUM'="")

                       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 

 +16       IF MLEN>RMAR

               DO CKP^GMTSUP

               IF $DATA(GMTSQIT)

                   QUIT 

               WRITE !

REPORT(LOOP,MCL,RMAR,BLINE,TV,VV,SP) ;Report on 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 a word to upper/lower 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

           IF SPAC<0

               SET SPAC=0

 +7        FOR LOOP2=1:1:TMAX

               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      ;

 +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