- 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
