BHSMEAP ;IHS/CIA/MGH - Health Summary for Measurement Panels ;09-Dec-2010 09:21;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,4**;Mar 17, 2006;Build 13
;===================================================================
;Taken from APCHS2A
; IHS/TUCSON/LAB - PART 2A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
;VA Health summary format of IHS health summary component for measurement panels
;Patch 4 skip vitals entered in error
MEASP ; ******************** MEASUREMENT PANELS * 9000010.01 *******
; <SETUP>
N BHSPAT,BHSP,BHSQ,APCHSPAT,APCHSIDT
S (BHSPAT,APCHSPAT)=DFN
Q:'$D(^AUPNVMSR("AA",BHSPAT))
D CKP^GMTSUP
; <BUILD> BHSCTL-HLTH SUM TYPE
Q:$O(GMTSEG(GMTSEGN,9001017,0))'>0
F BHSPOR=0:0 S BHSPOR=$O(GMTSEG(GMTSEGN,9001017,BHSPOR)) Q:'BHSPOR!(BHSPOR?1A) S BHSND2=GMTSNDM,BHSDMX=0 D PBLD
MEASPX K BHSPOR,BHSPDF,BHSCOR,BHSCT,BHSCT2,BHSCT3,BHSCLN,BHSMT,BHSML,BHSTSQ,BHSTVL,BHSVAL,APCHSIVD,BHST,BHSC,BHSND2,BHSDMX,BHSDFN,BHSEDAT,BHSDAT,BHSDM2,BHSPS1,BHSIDT,BHSNTS,Y,X
Q
PBLD S BHSPDF=$G(GMTSEG(GMTSEGN,9001017,BHSPOR)) Q:BHSPDF=""
K BHSTSQ,BHSTVL,BHSNTS
S BHSNTS=0
F BHSPS1=1,0 F BHSCOR=0:0 S BHSCOR=$O(^APCHSMPN(BHSPDF,1,BHSCOR)) Q:BHSCOR=""!(BHSCOR?1A) D CBLD
D POUT
Q
CBLD S BHSP=^APCHSMPN(BHSPDF,1,BHSCOR,0) S BHSCT3=$G(^(1))
S BHSCT=$P(BHSP,U,2),BHSCLN=$P(BHSP,U,3)
S X=$P(BHSP,U,5) S:X]"" BHSNTS(X)=""
S:BHSCT="" BHSCT=" " S BHSCT2=$S($D(^AUTTMSR(BHSCT,0)):$P(^(0),U,1),1:BHSCT)
S:$P(BHSP,U,4)]"" BHSCT2=$P(BHSP,U,4)
S:BHSCLN="" BHSCLN=10
S BHSTSQ(BHSCOR,1)=BHSCT2,BHSTSQ(BHSCOR,2)=BHSCLN,BHSTSQ(BHSCOR,3)=BHSCT3
I BHSPS1 S APCHSIVD="" F BHSQ=0:0 S APCHSIVD=$O(^AUPNVMSR("AA",BHSPAT,BHSCT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>GMTSDLM) D CBLD2
I 'BHSPS1 S APCHSIVD=$O(^AUPNVMSR("AA",BHSPAT,BHSCT,0)) I APCHSIVD,'$D(BHSTVL(APCHSIVD,BHSCOR)) D CBLD3
Q
CBLD2 I '$D(BHSTVL(APCHSIVD)) S BHSND2=BHSND2-1 I BHSND2=-1 S BHSND2=0 Q:BHSDMX&(APCHSIVD'<BHSDMX) K BHSTVL(BHSDMX) F BHSDM2=0:0 S BHSDM2=$O(BHSTVL(BHSDM2)) Q:'BHSDM2 S BHSDMX=BHSDM2
S:APCHSIVD>BHSDMX BHSDMX=APCHSIVD
CBLD3 S BHSDFN="" F S BHSDFN=$O(^AUPNVMSR("AA",BHSPAT,BHSCT,APCHSIVD,BHSDFN)) Q:BHSDFN="" D
. Q:$P($G(^AUPNVMSR(BHSDFN,2)),U,1) ;entered in error
. S BHSVAL=$P(^AUPNVMSR(BHSDFN,0),U,4),BHSEDAT=$P($G(^AUPNVMSR(BHSDFN,12)),U,1)
.I BHSEDAT'="" S BHSEDAT=9999999-BHSEDAT
.I BHSEDAT="" S BHSEDAT=APCHSIVD
.S BHSTVL(BHSEDAT,BHSCOR)=BHSVAL_"^"_$P(^AUPNVMSR(BHSDFN,0),U,6)
Q
; <DISPLAY>
POUT D CKP^GMTSUP Q:$D(GMTSQIT) W !
D CKP^GMTSUP Q:$D(GMTSQIT) D PHDR
S APCHSIVD="" F BHSQ=0:0 S APCHSIVD=$O(BHSTVL(APCHSIVD)) Q:APCHSIVD="" D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG PHDR D PLINE
I $O(BHSNTS(0))]"" W ! S X="" F S X=$O(BHSNTS(X)) Q:X="" W X,!
Q
PHDR S BHST=16,BHSC=""
F BHSQ=0:0 S BHSC=$O(BHSTSQ(BHSC)) Q:BHSC="" S BHSMT=BHSTSQ(BHSC,1),BHSML=BHSTSQ(BHSC,2) W ?(BHST+1+(BHSML-$L(BHSMT)\2)),BHSMT S BHST=BHST+BHSML+2
W !
Q
PLINE S (BHSIDT,APCHSIDT)=APCHSIVD
;IHS/MSC/MGH changed to fix bug in date display
;S X=BHSIDT I BHSEDAT="" S X=-APCHSIVD\1+9999999
S X=-APCHSIDT+9999999
D REGDTM^GMTSU
S BHSDAT=X
W BHSDAT S BHST=18
S BHSC="" F BHSQ=0:0 S BHSC=$O(BHSTSQ(BHSC)) Q:BHSC="" D PVAL
W !
Q
PVAL ;
K BHSVNM
S BHSML=BHSTSQ(BHSC,2)
S (BHSVAL,BHSVNM)="",BHSVAL=$P($G(BHSTVL(APCHSIVD,BHSC)),U) I $P($G(BHSTVL(APCHSIVD,BHSC)),U,2)]"" S BHSVNM=$P($G(BHSTVL(APCHSIVD,BHSC)),U,2)
I BHSVAL]"" S X=BHSVAL X BHSTSQ(BHSC,3) S BHSVAL=$P(X,"^",1),X=$P(X,"^",2) S:X]"" BHSNTS(X)=""
S:BHSVAL]"" BHSVAL=$S($P(BHSML,".",2)="":$J(BHSVAL,$P(BHSML,".",1)),1:$J(BHSVAL,$P(BHSML,".",1),$P(BHSML,".",2)))
W ?BHST,BHSVAL S BHST=BHST+BHSML+2
K BHSVNM
Q
BHSMEAP ;IHS/CIA/MGH - Health Summary for Measurement Panels ;09-Dec-2010 09:21;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,4**;Mar 17, 2006;Build 13
+2 ;===================================================================
+3 ;Taken from APCHS2A
+4 ; IHS/TUCSON/LAB - PART 2A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+5 ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
+6 ;VA Health summary format of IHS health summary component for measurement panels
+7 ;Patch 4 skip vitals entered in error
MEASP ; ******************** MEASUREMENT PANELS * 9000010.01 *******
+1 ; <SETUP>
+2 NEW BHSPAT,BHSP,BHSQ,APCHSPAT,APCHSIDT
+3 SET (BHSPAT,APCHSPAT)=DFN
+4 IF '$DATA(^AUPNVMSR("AA",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
+6 ; <BUILD> BHSCTL-HLTH SUM TYPE
+7 IF $ORDER(GMTSEG(GMTSEGN,9001017,0))'>0
QUIT
+8 FOR BHSPOR=0:0
SET BHSPOR=$ORDER(GMTSEG(GMTSEGN,9001017,BHSPOR))
IF 'BHSPOR!(BHSPOR?1A)
QUIT
SET BHSND2=GMTSNDM
SET BHSDMX=0
DO PBLD
MEASPX KILL BHSPOR,BHSPDF,BHSCOR,BHSCT,BHSCT2,BHSCT3,BHSCLN,BHSMT,BHSML,BHSTSQ,BHSTVL,BHSVAL,APCHSIVD,BHST,BHSC,BHSND2,BHSDMX,BHSDFN,BHSEDAT,BHSDAT,BHSDM2,BHSPS1,BHSIDT,BHSNTS,Y,X
+1 QUIT
PBLD SET BHSPDF=$GET(GMTSEG(GMTSEGN,9001017,BHSPOR))
IF BHSPDF=""
QUIT
+1 KILL BHSTSQ,BHSTVL,BHSNTS
+2 SET BHSNTS=0
+3 FOR BHSPS1=1,0
FOR BHSCOR=0:0
SET BHSCOR=$ORDER(^APCHSMPN(BHSPDF,1,BHSCOR))
IF BHSCOR=""!(BHSCOR?1A)
QUIT
DO CBLD
+4 DO POUT
+5 QUIT
CBLD SET BHSP=^APCHSMPN(BHSPDF,1,BHSCOR,0)
SET BHSCT3=$GET(^(1))
+1 SET BHSCT=$PIECE(BHSP,U,2)
SET BHSCLN=$PIECE(BHSP,U,3)
+2 SET X=$PIECE(BHSP,U,5)
IF X]""
SET BHSNTS(X)=""
+3 IF BHSCT=""
SET BHSCT=" "
SET BHSCT2=$SELECT($DATA(^AUTTMSR(BHSCT,0)):$PIECE(^(0),U,1),1:BHSCT)
+4 IF $PIECE(BHSP,U,4)]""
SET BHSCT2=$PIECE(BHSP,U,4)
+5 IF BHSCLN=""
SET BHSCLN=10
+6 SET BHSTSQ(BHSCOR,1)=BHSCT2
SET BHSTSQ(BHSCOR,2)=BHSCLN
SET BHSTSQ(BHSCOR,3)=BHSCT3
+7 IF BHSPS1
SET APCHSIVD=""
FOR BHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVMSR("AA",BHSPAT,BHSCT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>GMTSDLM)
QUIT
DO CBLD2
+8 IF 'BHSPS1
SET APCHSIVD=$ORDER(^AUPNVMSR("AA",BHSPAT,BHSCT,0))
IF APCHSIVD
IF '$DATA(BHSTVL(APCHSIVD,BHSCOR))
DO CBLD3
+9 QUIT
CBLD2 IF '$DATA(BHSTVL(APCHSIVD))
SET BHSND2=BHSND2-1
IF BHSND2=-1
SET BHSND2=0
IF BHSDMX&(APCHSIVD'<BHSDMX)
QUIT
KILL BHSTVL(BHSDMX)
FOR BHSDM2=0:0
SET BHSDM2=$ORDER(BHSTVL(BHSDM2))
IF 'BHSDM2
QUIT
SET BHSDMX=BHSDM2
+1 IF APCHSIVD>BHSDMX
SET BHSDMX=APCHSIVD
CBLD3 SET BHSDFN=""
FOR
SET BHSDFN=$ORDER(^AUPNVMSR("AA",BHSPAT,BHSCT,APCHSIVD,BHSDFN))
IF BHSDFN=""
QUIT
Begin DoDot:1
+1 ;entered in error
IF $PIECE($GET(^AUPNVMSR(BHSDFN,2)),U,1)
QUIT
+2 SET BHSVAL=$PIECE(^AUPNVMSR(BHSDFN,0),U,4)
SET BHSEDAT=$PIECE($GET(^AUPNVMSR(BHSDFN,12)),U,1)
+3 IF BHSEDAT'=""
SET BHSEDAT=9999999-BHSEDAT
+4 IF BHSEDAT=""
SET BHSEDAT=APCHSIVD
+5 SET BHSTVL(BHSEDAT,BHSCOR)=BHSVAL_"^"_$PIECE(^AUPNVMSR(BHSDFN,0),U,6)
End DoDot:1
+6 QUIT
+7 ; <DISPLAY>
POUT DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
DO PHDR
+2 SET APCHSIVD=""
FOR BHSQ=0:0
SET APCHSIVD=$ORDER(BHSTVL(APCHSIVD))
IF APCHSIVD=""
QUIT
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO PHDR
DO PLINE
+3 IF $ORDER(BHSNTS(0))]""
WRITE !
SET X=""
FOR
SET X=$ORDER(BHSNTS(X))
IF X=""
QUIT
WRITE X,!
+4 QUIT
PHDR SET BHST=16
SET BHSC=""
+1 FOR BHSQ=0:0
SET BHSC=$ORDER(BHSTSQ(BHSC))
IF BHSC=""
QUIT
SET BHSMT=BHSTSQ(BHSC,1)
SET BHSML=BHSTSQ(BHSC,2)
WRITE ?(BHST+1+(BHSML-$LENGTH(BHSMT)\2)),BHSMT
SET BHST=BHST+BHSML+2
+2 WRITE !
+3 QUIT
PLINE SET (BHSIDT,APCHSIDT)=APCHSIVD
+1 ;IHS/MSC/MGH changed to fix bug in date display
+2 ;S X=BHSIDT I BHSEDAT="" S X=-APCHSIVD\1+9999999
+3 SET X=-APCHSIDT+9999999
+4 DO REGDTM^GMTSU
+5 SET BHSDAT=X
+6 WRITE BHSDAT
SET BHST=18
+7 SET BHSC=""
FOR BHSQ=0:0
SET BHSC=$ORDER(BHSTSQ(BHSC))
IF BHSC=""
QUIT
DO PVAL
+8 WRITE !
+9 QUIT
PVAL ;
+1 KILL BHSVNM
+2 SET BHSML=BHSTSQ(BHSC,2)
+3 SET (BHSVAL,BHSVNM)=""
SET BHSVAL=$PIECE($GET(BHSTVL(APCHSIVD,BHSC)),U)
IF $PIECE($GET(BHSTVL(APCHSIVD,BHSC)),U,2)]""
SET BHSVNM=$PIECE($GET(BHSTVL(APCHSIVD,BHSC)),U,2)
+4 IF BHSVAL]""
SET X=BHSVAL
XECUTE BHSTSQ(BHSC,3)
SET BHSVAL=$PIECE(X,"^",1)
SET X=$PIECE(X,"^",2)
IF X]""
SET BHSNTS(X)=""
+5 IF BHSVAL]""
SET BHSVAL=$SELECT($PIECE(BHSML,".",2)="":$JUSTIFY(BHSVAL,$PIECE(BHSML,".",1)),1:$JUSTIFY(BHSVAL,$PIECE(BHSML,".",1),$PIECE(BHSML,".",2)))
+6 WRITE ?BHST,BHSVAL
SET BHST=BHST+BHSML+2
+7 KILL BHSVNM
+8 QUIT
