- BHSNT ;IHS/CIA/MGH - Health Summary for NARRATIVE TEXT file ;17-Mar-2006 10:36;MGH
- ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
- ;===================================================================
- ;VA health summary component for narrative text
- ;Taken from APCHS81
- ; IHS/TUCSON/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- ;;2.0;IHS RPMS/PCC Health Summary;**2,3,8**;JUN 24, 1997
- NT ; ******************** NARRATIVE TEXT 9000010.34 ******
- K BHSTXA
- ; <SETUP>
- N BHSPAT,BHSQ,X,Y
- S BHSPAT=DFN
- Q:'$D(^AUPNVNT("AA",BHSPAT))
- ; <DISPLAY>
- D CKP^GMTSUP Q:$D(GMTSQIT) W !
- S BHSTT="" F BHSQ=0:0 S BHSTT=$O(^AUPNVNT("AA",BHSPAT,BHSTT)) Q:BHSTT="" D
- .S BHSND2=GMTSNDM D NTDTYP Q:$D(GMTSQIT)
- D WRITE
- ; <CLEANUP>
- NTX K BHSTT,BHSTT2,BHSTT3,BHSDFN,BHSND2,BHSDAT,BHSIVD,BHSTXA,APCHWP,APCHX,BHSNDM
- Q
- NTDTYP S BHSTT2=$S($D(^AUTTNTYP(BHSTT,0)):$P(^(0),U,1),1:BHSTT) S BHSTT3=BHSTT2
- S (BHSIVD,BHSDFN)="" F S BHSIVD=$O(^AUPNVNT("AA",BHSPAT,BHSTT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) S BHSND2=BHSND2-1 Q:BHSND2=-1 D NTDSP
- Q
- NTDSP ;
- S BHSDFN=0 F S BHSDFN=$O(^AUPNVNT("AA",BHSPAT,BHSTT,BHSIVD,BHSDFN)) Q:BHSDFN'=+BHSDFN!($D(GMTSQIT)) S Y=-BHSIVD\1+9999999 D
- .S BHSTXA(BHSIVD,BHSTT,BHSDFN)=""
- Q
- ;
- WRITE ;write out Narrative text
- S BHSIVD=0 F S BHSIVD=$O(BHSTXA(BHSIVD)) Q:BHSIVD=""!($D(GMTSSQIT)) D
- .S BHSTT=0 F S BHSTT=$O(BHSTXA(BHSIVD,BHSTT)) Q:BHSTT=""!($D(GMTSQIT)) D
- ..S BHSDFN=0 F S BHSDFN=$O(BHSTXA(BHSIVD,BHSTT,BHSDFN)) Q:BHSDFN'=+BHSDFN!($D(BHSQIT)) D
- ...D CKP^GMTSUP Q:$D(GMTSQIT)
- ...W !,$$FMTE^XLFDT(9999999-BHSIVD),?23,$P(^AUTTNTYP(BHSTT,0),U)
- ... K APCHWP D WP
- ...S APCHX=0 F S APCHX=$O(APCHWP(APCHX)) Q:APCHX'=+APCHX!($D(GMTSQIT)) D
- ....D CKP^GMTSUP Q:$D(GMTSQIT)
- ....W !?3,APCHWP(APCHX)
- ....Q
- ...Q
- ..Q
- .Q
- Q
- WP ;EP - Entry point to print wp fields pass node in APCHWP
- NEW APCHG,APCHX,CNT
- K ^UTILITY($J,"W")
- S APCHX=0
- S DIWL=1,DIWR=70 F S APCHX=$O(^AUPNVNT(BHSDFN,11,APCHX)) Q:APCHX'=+APCHX D
- .S X=^AUPNVNT(BHSDFN,11,APCHX,0) D ^DIWP
- .Q
- S (Z,CNT)=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S CNT=CNT+1,APCHWP(CNT)=^UTILITY($J,"W",DIWL,Z,0)
- K DIWL,DIWR,DIWF,Z
- K ^UTILITY($J,"W"),APCHG,CNT,APCHX
- Q
- BHSNT ;IHS/CIA/MGH - Health Summary for NARRATIVE TEXT file ;17-Mar-2006 10:36;MGH
- +1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
- +2 ;===================================================================
- +3 ;VA health summary component for narrative text
- +4 ;Taken from APCHS81
- +5 ; IHS/TUCSON/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- +6 ;;2.0;IHS RPMS/PCC Health Summary;**2,3,8**;JUN 24, 1997
- NT ; ******************** NARRATIVE TEXT 9000010.34 ******
- +1 KILL BHSTXA
- +2 ; <SETUP>
- +3 NEW BHSPAT,BHSQ,X,Y
- +4 SET BHSPAT=DFN
- +5 IF '$DATA(^AUPNVNT("AA",BHSPAT))
- QUIT
- +6 ; <DISPLAY>
- +7 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- WRITE !
- +8 SET BHSTT=""
- FOR BHSQ=0:0
- SET BHSTT=$ORDER(^AUPNVNT("AA",BHSPAT,BHSTT))
- IF BHSTT=""
- QUIT
- Begin DoDot:1
- +9 SET BHSND2=GMTSNDM
- DO NTDTYP
- IF $DATA(GMTSQIT)
- QUIT
- End DoDot:1
- +10 DO WRITE
- +11 ; <CLEANUP>
- NTX KILL BHSTT,BHSTT2,BHSTT3,BHSDFN,BHSND2,BHSDAT,BHSIVD,BHSTXA,APCHWP,APCHX,BHSNDM
- +1 QUIT
- NTDTYP SET BHSTT2=$SELECT($DATA(^AUTTNTYP(BHSTT,0)):$PIECE(^(0),U,1),1:BHSTT)
- SET BHSTT3=BHSTT2
- +1 SET (BHSIVD,BHSDFN)=""
- FOR
- SET BHSIVD=$ORDER(^AUPNVNT("AA",BHSPAT,BHSTT,BHSIVD))
- IF BHSIVD=""!(BHSIVD>GMTSDLM)
- QUIT
- SET BHSND2=BHSND2-1
- IF BHSND2=-1
- QUIT
- DO NTDSP
- +2 QUIT
- NTDSP ;
- +1 SET BHSDFN=0
- FOR
- SET BHSDFN=$ORDER(^AUPNVNT("AA",BHSPAT,BHSTT,BHSIVD,BHSDFN))
- IF BHSDFN'=+BHSDFN!($DATA(GMTSQIT))
- QUIT
- SET Y=-BHSIVD\1+9999999
- Begin DoDot:1
- +2 SET BHSTXA(BHSIVD,BHSTT,BHSDFN)=""
- End DoDot:1
- +3 QUIT
- +4 ;
- WRITE ;write out Narrative text
- +1 SET BHSIVD=0
- FOR
- SET BHSIVD=$ORDER(BHSTXA(BHSIVD))
- IF BHSIVD=""!($DATA(GMTSSQIT))
- QUIT
- Begin DoDot:1
- +2 SET BHSTT=0
- FOR
- SET BHSTT=$ORDER(BHSTXA(BHSIVD,BHSTT))
- IF BHSTT=""!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:2
- +3 SET BHSDFN=0
- FOR
- SET BHSDFN=$ORDER(BHSTXA(BHSIVD,BHSTT,BHSDFN))
- IF BHSDFN'=+BHSDFN!($DATA(BHSQIT))
- QUIT
- Begin DoDot:3
- +4 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +5 WRITE !,$$FMTE^XLFDT(9999999-BHSIVD),?23,$PIECE(^AUTTNTYP(BHSTT,0),U)
- +6 KILL APCHWP
- DO WP
- +7 SET APCHX=0
- FOR
- SET APCHX=$ORDER(APCHWP(APCHX))
- IF APCHX'=+APCHX!($DATA(GMTSQIT))
- QUIT
- Begin DoDot:4
- +8 DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- +9 WRITE !?3,APCHWP(APCHX)
- +10 QUIT
- End DoDot:4
- +11 QUIT
- End DoDot:3
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 QUIT
- WP ;EP - Entry point to print wp fields pass node in APCHWP
- +1 NEW APCHG,APCHX,CNT
- +2 KILL ^UTILITY($JOB,"W")
- +3 SET APCHX=0
- +4 SET DIWL=1
- SET DIWR=70
- FOR
- SET APCHX=$ORDER(^AUPNVNT(BHSDFN,11,APCHX))
- IF APCHX'=+APCHX
- QUIT
- Begin DoDot:1
- +5 SET X=^AUPNVNT(BHSDFN,11,APCHX,0)
- DO ^DIWP
- +6 QUIT
- End DoDot:1
- +7 SET (Z,CNT)=0
- FOR
- SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
- IF Z'=+Z
- QUIT
- SET CNT=CNT+1
- SET APCHWP(CNT)=^UTILITY($JOB,"W",DIWL,Z,0)
- +8 KILL DIWL,DIWR,DIWF,Z
- +9 KILL ^UTILITY($JOB,"W"),APCHG,CNT,APCHX
- +10 QUIT
