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
