- 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
