ORDV08A.m

ORDV08A ; slc/dan Medicine procedure component ;8/13/01  14:42

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109**;Dec 17,1997

GETREC(MCL,RMAR,TV,VV,SP) ; Return Single Record

 N LOOP,LINE,LINENO

 S LOOP="",LINENO=1

 S ORDATE=$$RETURN("DATE/TIME",MCL)

 S ORSUM=$$RETURN("SUMMARY",MCL)

 S ORPROC=$$RETURN("PROCEDURE",MCL)

 ;S ^TMP("ORTEMP",$J,LINENO)="",LINENO=LINENO+1

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

 Q

REPORT(LOOP,MCL,RMAR,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)

 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)

 S ^TMP("ORTEMP",$J,LINENO)="",LINENO=LINENO+1

 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,SPACE

 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  D

 . K SPACE S $P(SPACE," ",SP)=" " S ^TMP("ORTEMP",$J,LINENO)=$J($G(TARRAY(LOOP3)),TV)_SPACE_^UTILITY($J,"W",DIWL,SLOOP,0),LINENO=LINENO+1

 S ^TMP("ORTEMP",$J,LINENO)="",LINENO=LINENO+1

 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,SPACE

 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

 . K SPACE S $P(SPACE," ",SP)=" ",^TMP("ORTEMP",$J,LINENO)=$J($G(TARRAY(LOOP2)),TV)_SPACE_$G(VARRAY(LOOP2-SPAC)),LINENO=LINENO+1

 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

ORDV08A   ; slc/dan Medicine procedure component ;8/13/01  14:42

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109**;Dec 17,1997

GETREC(MCL,RMAR,TV,VV,SP) ; Return Single Record

 +1        NEW LOOP,LINE,LINENO

 +2        SET LOOP=""

           SET LINENO=1

 +3        SET ORDATE=$$RETURN("DATE/TIME",MCL)

 +4        SET ORSUM=$$RETURN("SUMMARY",MCL)

 +5        SET ORPROC=$$RETURN("PROCEDURE",MCL)

 +6       ;S ^TMP("ORTEMP",$J,LINENO)="",LINENO=LINENO+1

 +7        FOR 

               SET LOOP=+$ORDER(^TMP("MCAR",$JOB,MCL,LOOP))

               IF LOOP=0

                   QUIT 

               DO REPORT(LOOP,MCL,RMAR,TV,VV,SP)

 +8        QUIT 

REPORT(LOOP,MCL,RMAR,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 $PIECE(TEMP,";",2)="W"

               DO WORD(MCL,LOOP,TITLE,RMAR,TV,VV,SP)

               QUIT 

 +7        SET VALUE=VALUE_$SELECT(UNITS="":"",1:" "_UNITS)

 +8        DO PRINT(VALUE,VV,TITLE,TV,SP)

 +9        SET ^TMP("ORTEMP",$JOB,LINENO)=""

           SET LINENO=LINENO+1

 +10       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,SPACE

 +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

                   QUIT 

               Begin DoDot:1

 +7                KILL SPACE

                   SET $PIECE(SPACE," ",SP)=" "

                   SET ^TMP("ORTEMP",$JOB,LINENO)=$JUSTIFY($GET(TARRAY(LOOP3)),TV)_SPACE_^UTILITY($JOB,"W",DIWL,SLOOP,0)

                   SET LINENO=LINENO+1

               End DoDot:1

 +8        SET ^TMP("ORTEMP",$JOB,LINENO)=""

           SET LINENO=LINENO+1

 +9        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,SPACE

 +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

               Begin DoDot:1

 +8                KILL SPACE

                   SET $PIECE(SPACE," ",SP)=" "

                   SET ^TMP("ORTEMP",$JOB,LINENO)=$JUSTIFY($GET(TARRAY(LOOP2)),TV)_SPACE_$GET(VARRAY(LOOP2-SPAC))

                   SET LINENO=LINENO+1

               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