GMTSMCPZ.m

GMTSMCPZ ; SLC/SBW,KER - Medicine 2.0 HS Component ; 11/02/1998

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

 K WH,%DT,X,Y Q

BEG ;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE

 D KVAR^VADPT

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

 E  S MAX=50

LOC ;LOCATE PROCEDURES FROM "AC" X-REF

 I '$D(^MCAR(690,"AC",DFN)) G EXIT

 K ^TMP("MCAR",$J) S S4=GMTS1-.0001 F M=1:1:MAX S S4=$O(^MCAR(690,"AC",DFN,S4)) Q:S4=""!(S4>GMTS2)  D LOCFIL

 G PR0

LOCFIL G LOCFIL1:$D(S5) S S5="" F K=1:1 S S5=$O(^MCAR(690,"AC",DFN,S4,S5)) Q:S5=""  D LOCFIL1

 K S5 Q

LOCFIL1 ; Set S5 to the PROCEDURE LOCATION (^MCAR(697.2,Y,0))

 S S6="" F L=1:1 S S6=$O(^MCAR(690,"AC",DFN,S4,S5,S6)) Q:S6=""  D CONT

 Q

CONT I S5[699 S (LL,LL1)=$P(^MCAR(699,S6,0),U,12),LL=$P(^MCAR(697.2,LL,0),U) G CONT1:'$D(PE) Q:PE'=LL  G CONT1

 I S5[694 S (LL,LL1)=$P(^MCAR(694,S6,0),U,3),LL=$P(^MCAR(697.2,LL,0),U) G CONT1:'$D(PE) Q:PE'=LL  G CONT1

 S (LL,LL1)=$O(^MCAR(697.2,"C",S5,0)),LL=$P(^MCAR(697.2,LL,0),U,1)

CONT1 S MCARSUM="",MCARFILE=U_S5_","_S6_",.2)" S:$D(@MCARFILE) MCARSUM=$P(@MCARFILE,U,1)

 K MCARFILE S S1=S4,S2=LL

 S ^TMP("MCAR",$J,S1,S2)=MCARSUM_U_S6_U_$P(^MCAR(697.2,LL1,0),U,5,7) K MCARSUM Q

PR0 I '$D(^TMP("MCAR",$J)) G EXIT

 S I="",L=0

PR1 S I=$O(^TMP("MCAR",$J,I)) G PR1:I="OT" I I="" G EXIT

 S J=""

PR2 S J=$O(^TMP("MCAR",$J,I,J)) G PR1:J="" S MCARDT=I,MCARPROC=J,PR=^(J)

 S DA=$P(PR,U,2),K=$P(PR,U)

 S K=$S(K="N"!(K="L"):"NORMAL",K="A":"ABNORMAL",K="B":"BORDERLINE",K="T":"TECHNICALLY UNSATISFACTORY",K="ND":"NON-DIAGNOSTIC",1:"")

 S Y=9999999.9999-MCARDT X ^DD("DD") D DFIX,CKP^GMTSUP Q:$D(GMTSQIT)  W Y,?23,MCARPROC,?62,K,!

 S ^TMP("MCAR",$J,"OT",L)=MCARPROC_U_DA_U_$P(PR,U,3,5)

 G PR2

DFIX ;

 S %DT="T",X=Y D ^%DT S X=Y D REGDTM4^GMTSU S Y=X Q

EXIT ;

 K PR,OT,DA,MCARPPS,I,J,R,L,S1,S2,S4,S5,S6,LL,LL1,MAX,VA

 K ^TMP("MCAR",$J),K,N,MCARDT,MCARNM,MCARPROC,M Q

GMTSMCPZ  ; SLC/SBW,KER - Medicine 2.0 HS Component ; 11/02/1998

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

 +2        KILL WH,%DT,X,Y

           QUIT 

BEG       ;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE

 +1        DO KVAR^VADPT

 +2        IF $DATA(GMTSNDM)

               IF (GMTSNDM>0)

                   SET MAX=GMTSNDM

 +3       IF '$TEST

               SET MAX=50

LOC       ;LOCATE PROCEDURES FROM "AC" X-REF

 +1        IF '$DATA(^MCAR(690,"AC",DFN))

               GOTO EXIT

 +2        KILL ^TMP("MCAR",$JOB)

           SET S4=GMTS1-.0001

           FOR M=1:1:MAX

               SET S4=$ORDER(^MCAR(690,"AC",DFN,S4))

               IF S4=""!(S4>GMTS2)

                   QUIT 

               DO LOCFIL

 +3        GOTO PR0

LOCFIL     IF $DATA(S5)

               GOTO LOCFIL1

           SET S5=""

           FOR K=1:1

               SET S5=$ORDER(^MCAR(690,"AC",DFN,S4,S5))

               IF S5=""

                   QUIT 

               DO LOCFIL1

 +1        KILL S5

           QUIT 

LOCFIL1   ; Set S5 to the PROCEDURE LOCATION (^MCAR(697.2,Y,0))

 +1        SET S6=""

           FOR L=1:1

               SET S6=$ORDER(^MCAR(690,"AC",DFN,S4,S5,S6))

               IF S6=""

                   QUIT 

               DO CONT

 +2        QUIT 

CONT       IF S5[699

               SET (LL,LL1)=$PIECE(^MCAR(699,S6,0),U,12)

               SET LL=$PIECE(^MCAR(697.2,LL,0),U)

               IF '$DATA(PE)

                   GOTO CONT1

               IF PE'=LL

                   QUIT 

               GOTO CONT1

 +1        IF S5[694

               SET (LL,LL1)=$PIECE(^MCAR(694,S6,0),U,3)

               SET LL=$PIECE(^MCAR(697.2,LL,0),U)

               IF '$DATA(PE)

                   GOTO CONT1

               IF PE'=LL

                   QUIT 

               GOTO CONT1

 +2        SET (LL,LL1)=$ORDER(^MCAR(697.2,"C",S5,0))

           SET LL=$PIECE(^MCAR(697.2,LL,0),U,1)

CONT1      SET MCARSUM=""

           SET MCARFILE=U_S5_","_S6_",.2)"

           IF $DATA(@MCARFILE)

               SET MCARSUM=$PIECE(@MCARFILE,U,1)

 +1        KILL MCARFILE

           SET S1=S4

           SET S2=LL

 +2        SET ^TMP("MCAR",$JOB,S1,S2)=MCARSUM_U_S6_U_$PIECE(^MCAR(697.2,LL1,0),U,5,7)

           KILL MCARSUM

           QUIT 

PR0        IF '$DATA(^TMP("MCAR",$JOB))

               GOTO EXIT

 +1        SET I=""

           SET L=0

PR1        SET I=$ORDER(^TMP("MCAR",$JOB,I))

           IF I="OT"

               GOTO PR1

           IF I=""

               GOTO EXIT

 +1        SET J=""

PR2        SET J=$ORDER(^TMP("MCAR",$JOB,I,J))

           IF J=""

               GOTO PR1

           SET MCARDT=I

           SET MCARPROC=J

           SET PR=^(J)

 +1        SET DA=$PIECE(PR,U,2)

           SET K=$PIECE(PR,U)

 +2        SET K=$SELECT(K="N"!(K="L"):"NORMAL",K="A":"ABNORMAL",K="B":"BORDERLINE",K="T":"TECHNICALLY UNSATISFACTORY",K="ND":"NON-DIAGNOSTIC",1:"")

 +3        SET Y=9999999.9999-MCARDT

           XECUTE ^DD("DD")

           DO DFIX

           DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           WRITE Y,?23,MCARPROC,?62,K,!

 +4        SET ^TMP("MCAR",$JOB,"OT",L)=MCARPROC_U_DA_U_$PIECE(PR,U,3,5)

 +5        GOTO PR2

DFIX      ;

 +1        SET %DT="T"

           SET X=Y

           DO ^%DT

           SET X=Y

           DO REGDTM4^GMTSU

           SET Y=X

           QUIT 

EXIT      ;

 +1        KILL PR,OT,DA,MCARPPS,I,J,R,L,S1,S2,S4,S5,S6,LL,LL1,MAX,VA

 +2        KILL ^TMP("MCAR",$JOB),K,N,MCARDT,MCARNM,MCARPROC,M

           QUIT