BHSPHN ;IHS/CIA/MGH - Health Summary for PUBLIC HEALTH NURSING file ;24-Aug-2012 14:24;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**7**;March 17, 2006;Build 12
;===================================================================
;Taken from APCHS2G
;IHS/TUCSON/LAB - PART 2B OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;**3**;JUN 24, 1997
;Routines to document public health nursing encounters from the visit file
;in the VA health summary component
OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
; <SETUP>
N BHSPAT,BHSN,BHSNTE,BHSQ,BHSTXT,X
S BHSPAT=DFN
Q:'$D(^AUPNVSIT("AA",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSPVD=0
S BHSPFN=""
F BHSIVD=0:0 S BHSIVD=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D Q:GMTSNDM=0!($D(GMTSQIT))
. D ONEDATE
. Q:$D(GMTSQIT)
. S:(BHSDAT'=BHSPVD)&BHSDTU GMTSNDM=GMTSNDM-BHSDTU,BHSPVD=BHSDAT
. Q
;
OUTPTX ; <CLEANUP>
K BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,BHSNDT,BHSCLI,BHSPDN,BHSICD,BHSICL,BHSNRQ,BHSPHN
K BHSNFL,BHSNSH,BHSCCL,BHSNAB,BHSVSC,BHSITE,BHSQIT,BHSDCL,Y
Q
;
ONEDATE ;
S BHSCCL=""
S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDTU=0,BHSNDT=(BHSDAT'=BHSPVD)
S BHSVDF="" F BHSQ=0:0 S BHSVDF=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD,BHSVDF)) Q:BHSVDF="" D Q:$D(GMTSQIT)
. S BHSSCL=""
. S BHSN=^AUPNVSIT(BHSVDF,0)
. Q:'$P(BHSN,U,9)
. Q:$P(BHSN,U,11)
. Q:'$$PHN(BHSVDF) ;do not use is phn is not a provider on this visit
. D GETCLN
. D GETSITEV^BHSUTL,DSPVIS
. Q:$D(GMTSQIT)
. Q
Q
;
GETCLN ;
;BHSDCL=set to 34 if Display Clinic is Yes, 23 if No
I $D(^GMT(142.1,GMTSE,0)),$P(^(0),U,10)="Y" D
.S BHSDCL=34
.S BHSCLI=$P(BHSN,U,8) I BHSCLI="" S BHSCCL="<none>" Q
.S BHSCLI=$P(BHSN,U,8) Q:BHSCLI=""
.Q:'$D(^DIC(40.7,BHSCLI))
.I $D(^DIC(40.7,BHSCLI,9999999)),$P(^(9999999),U,1)]"" S BHSCLI=$P(^DIC(40.7,BHSCLI,9999999),U,1),BHSCCL=BHSCLI Q
.S BHSCLI=$E($P(^DIC(40.7,BHSCLI,0),U,1),1,10)
.S BHSCCL=BHSCLI
E S BHSCLI=" ",BHSDCL=23 Q
Q
PHN(V) ;if one provider is phn quit on 1 otherwise quit on ""
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I '$D(^AUPNVPRV("AD",V)) Q ""
I $$PRIMPROV^APCLV(V,"D")=13!($$PRIMPROV^APCLV(V,"D")=32) Q 1
Q ""
;if include secondary remove lines above about primary
NEW %,%1,Y,P S Y=0,%1="" F S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y S P=$P(^AUPNVPRV(Y,0),U) D
.I $P(^DD(9000010.06,.01,0),U,2)[200,'$D(^VA(200,P)) Q
.I $P(^DD(9000010.06,.01,0),U,2)[6,'$D(^DIC(6,P)) Q
.S %=$$VALI^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),P,$S($P(^DD(9000010.06,.01,0),U,2)[200:53.5,1:2)) I % S %=$P($G(^DIC(7,%,9999999)),U)
.I %=13!(%=32) S %1=1
Q %1
DSPVIS ;
S BHSDTU=1
I $O(^AUPNVPOV("AD",BHSVDF,""))="" D NOPOV Q
S BHSPDN="" F BHSQ=0:0 S BHSPDN=$O(^AUPNVPOV("AD",BHSVDF,BHSPDN)) Q:'BHSPDN S BHSN=^AUPNVPOV(BHSPDN,0) D HASPOV
Q
;
NOPOV ;
S (BHSICD,BHSNRQ)="<purpose of visit not yet entered>",BHSMOD=""
G COMMON
;
HASPOV ;
S BHSICD=$P(BHSN,U,1) D GETICDDX^BHSUTL
S BHSNRQ=$P(BHSN,U,4) D GETNARR^BHSUTL I $P(BHSN,U,5)]"" S BHSNRQ=BHSNRQ_" (Stage: "_$P(BHSN,U,5)_")" ;IHS/CMI/LAB
S BHSMOD=$P(BHSN,U,6)
COMMON ;
D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG BHSNDT=1
I BHSNDT W !,BHSDAT S (BHSPFN,BHSSCL)="",BHSNDT=0
I BHSNSH=BHSPFN S BHSFAC=""
E S (BHSFAC,BHSPFN)=BHSNSH,BHSSCL=""
I BHSCCL=BHSSCL S BHSCLI=""
E S (BHSCLI,BHSSCL)=BHSCCL
I BHSICD["<purpose of visit not"&(BHSSCL="<none>") S BHSCLI=""
I BHSMOD]"" S BHSMTX=$P(^DD(9000010.07,.06,0),U,3),BHSMTX=$P($P(BHSMTX,BHSMOD_":",2),";",1),BHSMTX=$P(BHSMTX,",",1),BHSICD=BHSMTX_" "_BHSICD
S:$D(^AUPNVCHS("AD",BHSVDF)) BHSNTE="*** CHS ***"
W ?12,BHSFAC W:BHSCLI]"" ?23,BHSCLI
S BHSICL=$S(BHSDCL=34:34,1:24)
S:0 BHSICD=BHSVSC_":"_BHSICD D PRTICD^BHSUTL
Q
GOALS(BHSVDF) ;display phn fields
Q:'$D(^AUPNVPHN("AD",BHSVDF))
S BHSPHN=$O(^AUPNVPHN("AD",BHSVDF,0))
Q:'BHSPHN
I $P(^AUPNVPHN(BHSPHN,0),U,5)]"" D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG BHSNDT=1 W ?BHSICL,"Intervention: ",$$VAL^XBDIQ1(9000010.32,BHSPHN,.05)
I $P(^AUPNVPHN(BHSPHN,0),U,6)]"" D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG BHSNDT=1 W !?BHSICL,"Complexity: ",$$VAL^XBDIQ1(9000010.32,BHSPHN,.06)
I $P(^AUPNVPHN(BHSPHN,0),U,5)]""!($P(^AUPNVPHN(BHSPHN,0),U,6)]"") W !
I $D(^AUPNVPHN(BHSPHN,21)) S BHSTXT="Psycho/Soc/Env: "_^AUPNVPHN(BHSPHN,21),BHSICL=$S(BHSDCL=34:34,1:24)+1 D PRTTXT
I $D(^AUPNVPHN(BHSPHN,22)) S BHSTXT="NSG Dx: "_^AUPNVPHN(BHSPHN,22),BHSICL=$S(BHSDCL=34:34,1:24)+1 D PRTTXT
I $D(^AUPNVPHN(BHSPHN,23)) S BHSTXT="Short Term Goals: "_^AUPNVPHN(BHSPHN,23),BHSICL=$S(BHSDCL=34:34,1:24)+1 D PRTTXT
I $D(^AUPNVPHN(BHSPHN,24)) S BHSTXT="Long Term Goals: "_^AUPNVPHN(BHSPHN,24),BHSICL=$S(BHSDCL=34:34,1:24)+1 D PRTTXT
Q
;
DETAIL ; ********** PHN OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
; <SETUP>
N BHSPAT,BHSN,BHSNTE,BHSQ,BHSTXT,X
S BHSPAT=DFN
Q:'$D(^AUPNVSIT("AA",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSPVD=0
S BHSPFN=""
F BHSIVD=0:0 S BHSIVD=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D Q:GMTSNDM=0!($D(GMTSQIT))
. D ONEVST
. Q:$D(GMTSQIT)
. S:(BHSDAT'=BHSPVD)&BHSDTU GMTSNDM=GMTSNDM-BHSDTU,BHSPVD=BHSDAT
. Q
;
CLEAN ; <CLEANUP>
K BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,BHSNDT,BHSCLI,BHSPDN,BHSICD,BHSICL,BHSNRQ,BHSPHN
K BHSNFL,BHSNSH,BHSCCL,BHSNAB,BHSVSC,BHSITE,BHSQIT,BHSDCL,Y
Q
;
ONEVST ;
S BHSCCL=""
S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDTU=0,BHSNDT=(BHSDAT'=BHSPVD)
S BHSVDF="" F BHSQ=0:0 S BHSVDF=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD,BHSVDF)) Q:BHSVDF="" D Q:$D(GMTSQIT)
. S BHSSCL=""
. S BHSN=^AUPNVSIT(BHSVDF,0)
. Q:'$P(BHSN,U,9)
. Q:$P(BHSN,U,11)
. Q:'$D(^AUPNVPHN("AD",BHSVDF))
. S GMTSNDM=GMTSNDM-1
. D GETCLN
. D GETSITEV^BHSUTL,DSPVIS
. D GOALS(BHSVDF)
. Q:$D(GMTSQIT)
. Q
Q
PRTTXT ;Print text
N BHSQ
S:'$D(BHSNTE) BHSNTE=""
S BHSDLT=1,BHSILN=IOM-BHSICL-1
F BHSQ=0:0 D PRTTXT1 Q:BHSTXT="" D PRTTXT2
K BHSNTE
K BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
Q
PRTTXT1 ;
S:($L(BHSTXT)+2)<255 BHSTXT=$S(BHSTXT]"":BHSTXT,1:""),BHSNRQ=""
S:BHSNTE]""&(($L(BHSTXT)+2)<255) BHSTXT=BHSTXT_BHSNTE,BHSNTE=""
Q
PRTTXT2 D GETFRAG D CKP^GMTSUP Q:$D(GMTSQIT) W ?BHSICL W BHSF,! S BHSICL=BHSICL+BHSDLT,BHSILN=BHSILN-BHSDLT,BHSDLT=0
Q
GETFRAG I $L(BHSTXT)<BHSILN S BHSF=BHSTXT,BHSTXT="" Q
F BHSC=BHSILN:-1:0 Q:$E(BHSTXT,BHSC)=" "
S:BHSC=0 BHSC=BHSILN
S BHSF=$E(BHSTXT,1,BHSC-1),BHSTXT=$E(BHSTXT,BHSC+1,255)
Q
BHSPHN ;IHS/CIA/MGH - Health Summary for PUBLIC HEALTH NURSING file ;24-Aug-2012 14:24;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**7**;March 17, 2006;Build 12
+2 ;===================================================================
+3 ;Taken from APCHS2G
+4 ;IHS/TUCSON/LAB - PART 2B OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+5 ;;2.0;IHS RPMS/PCC Health Summary;**3**;JUN 24, 1997
+6 ;Routines to document public health nursing encounters from the visit file
+7 ;in the VA health summary component
OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 NEW BHSPAT,BHSN,BHSNTE,BHSQ,BHSTXT,X
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVSIT("AA",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 SET BHSPVD=0
+8 SET BHSPFN=""
+9 FOR BHSIVD=0:0
SET BHSIVD=$ORDER(^AUPNVSIT("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+10 DO ONEDATE
+11 IF $DATA(GMTSQIT)
QUIT
+12 IF (BHSDAT'=BHSPVD)&BHSDTU
SET GMTSNDM=GMTSNDM-BHSDTU
SET BHSPVD=BHSDAT
+13 QUIT
End DoDot:1
IF GMTSNDM=0!($DATA(GMTSQIT))
QUIT
+14 ;
OUTPTX ; <CLEANUP>
+1 KILL BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,BHSNDT,BHSCLI,BHSPDN,BHSICD,BHSICL,BHSNRQ,BHSPHN
+2 KILL BHSNFL,BHSNSH,BHSCCL,BHSNAB,BHSVSC,BHSITE,BHSQIT,BHSDCL,Y
+3 QUIT
+4 ;
ONEDATE ;
+1 SET BHSCCL=""
+2 SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+3 SET BHSDTU=0
SET BHSNDT=(BHSDAT'=BHSPVD)
+4 SET BHSVDF=""
FOR BHSQ=0:0
SET BHSVDF=$ORDER(^AUPNVSIT("AA",BHSPAT,BHSIVD,BHSVDF))
IF BHSVDF=""
QUIT
Begin DoDot:1
+5 SET BHSSCL=""
+6 SET BHSN=^AUPNVSIT(BHSVDF,0)
+7 IF '$PIECE(BHSN,U,9)
QUIT
+8 IF $PIECE(BHSN,U,11)
QUIT
+9 ;do not use is phn is not a provider on this visit
IF '$$PHN(BHSVDF)
QUIT
+10 DO GETCLN
+11 DO GETSITEV^BHSUTL
DO DSPVIS
+12 IF $DATA(GMTSQIT)
QUIT
+13 QUIT
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+14 QUIT
+15 ;
GETCLN ;
+1 ;BHSDCL=set to 34 if Display Clinic is Yes, 23 if No
+2 IF $DATA(^GMT(142.1,GMTSE,0))
IF $PIECE(^(0),U,10)="Y"
Begin DoDot:1
+3 SET BHSDCL=34
+4 SET BHSCLI=$PIECE(BHSN,U,8)
IF BHSCLI=""
SET BHSCCL="<none>"
QUIT
+5 SET BHSCLI=$PIECE(BHSN,U,8)
IF BHSCLI=""
QUIT
+6 IF '$DATA(^DIC(40.7,BHSCLI))
QUIT
+7 IF $DATA(^DIC(40.7,BHSCLI,9999999))
IF $PIECE(^(9999999),U,1)]""
SET BHSCLI=$PIECE(^DIC(40.7,BHSCLI,9999999),U,1)
SET BHSCCL=BHSCLI
QUIT
+8 SET BHSCLI=$EXTRACT($PIECE(^DIC(40.7,BHSCLI,0),U,1),1,10)
+9 SET BHSCCL=BHSCLI
End DoDot:1
+10 IF '$TEST
SET BHSCLI=" "
SET BHSDCL=23
QUIT
+11 QUIT
PHN(V) ;if one provider is phn quit on 1 otherwise quit on ""
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF '$DATA(^AUPNVPRV("AD",V))
QUIT ""
+4 IF $$PRIMPROV^APCLV(V,"D")=13!($$PRIMPROV^APCLV(V,"D")=32)
QUIT 1
+5 QUIT ""
+6 ;if include secondary remove lines above about primary
+7 NEW %,%1,Y,P
SET Y=0
SET %1=""
FOR
SET Y=$ORDER(^AUPNVPRV("AD",V,Y))
IF Y'=+Y
QUIT
SET P=$PIECE(^AUPNVPRV(Y,0),U)
Begin DoDot:1
+8 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
IF '$DATA(^VA(200,P))
QUIT
+9 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
IF '$DATA(^DIC(6,P))
QUIT
+10 SET %=$$VALI^XBDIQ1($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:200,1:6),P,$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:53.5,1:2))
IF %
SET %=$PIECE($GET(^DIC(7,%,9999999)),U)
+11 IF %=13!(%=32)
SET %1=1
End DoDot:1
+12 QUIT %1
DSPVIS ;
+1 SET BHSDTU=1
+2 IF $ORDER(^AUPNVPOV("AD",BHSVDF,""))=""
DO NOPOV
QUIT
+3 SET BHSPDN=""
FOR BHSQ=0:0
SET BHSPDN=$ORDER(^AUPNVPOV("AD",BHSVDF,BHSPDN))
IF 'BHSPDN
QUIT
SET BHSN=^AUPNVPOV(BHSPDN,0)
DO HASPOV
+4 QUIT
+5 ;
NOPOV ;
+1 SET (BHSICD,BHSNRQ)="<purpose of visit not yet entered>"
SET BHSMOD=""
+2 GOTO COMMON
+3 ;
HASPOV ;
+1 SET BHSICD=$PIECE(BHSN,U,1)
DO GETICDDX^BHSUTL
+2 ;IHS/CMI/LAB
SET BHSNRQ=$PIECE(BHSN,U,4)
DO GETNARR^BHSUTL
IF $PIECE(BHSN,U,5)]""
SET BHSNRQ=BHSNRQ_" (Stage: "_$PIECE(BHSN,U,5)_")"
+3 SET BHSMOD=$PIECE(BHSN,U,6)
COMMON ;
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET BHSNDT=1
+2 IF BHSNDT
WRITE !,BHSDAT
SET (BHSPFN,BHSSCL)=""
SET BHSNDT=0
+3 IF BHSNSH=BHSPFN
SET BHSFAC=""
+4 IF '$TEST
SET (BHSFAC,BHSPFN)=BHSNSH
SET BHSSCL=""
+5 IF BHSCCL=BHSSCL
SET BHSCLI=""
+6 IF '$TEST
SET (BHSCLI,BHSSCL)=BHSCCL
+7 IF BHSICD["<purpose of visit not"&(BHSSCL="<none>")
SET BHSCLI=""
+8 IF BHSMOD]""
SET BHSMTX=$PIECE(^DD(9000010.07,.06,0),U,3)
SET BHSMTX=$PIECE($PIECE(BHSMTX,BHSMOD_":",2),";",1)
SET BHSMTX=$PIECE(BHSMTX,",",1)
SET BHSICD=BHSMTX_" "_BHSICD
+9 IF $DATA(^AUPNVCHS("AD",BHSVDF))
SET BHSNTE="*** CHS ***"
+10 WRITE ?12,BHSFAC
IF BHSCLI]""
WRITE ?23,BHSCLI
+11 SET BHSICL=$SELECT(BHSDCL=34:34,1:24)
+12 IF 0
SET BHSICD=BHSVSC_":"_BHSICD
DO PRTICD^BHSUTL
+13 QUIT
GOALS(BHSVDF) ;display phn fields
+1 IF '$DATA(^AUPNVPHN("AD",BHSVDF))
QUIT
+2 SET BHSPHN=$ORDER(^AUPNVPHN("AD",BHSVDF,0))
+3 IF 'BHSPHN
QUIT
+4 IF $PIECE(^AUPNVPHN(BHSPHN,0),U,5)]""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET BHSNDT=1
WRITE ?BHSICL,"Intervention: ",$$VAL^XBDIQ1(9000010.32,BHSPHN,.05)
+5 IF $PIECE(^AUPNVPHN(BHSPHN,0),U,6)]""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET BHSNDT=1
WRITE !?BHSICL,"Complexity: ",$$VAL^XBDIQ1(9000010.32,BHSPHN,.06)
+6 IF $PIECE(^AUPNVPHN(BHSPHN,0),U,5)]""!($PIECE(^AUPNVPHN(BHSPHN,0),U,6)]"")
WRITE !
+7 IF $DATA(^AUPNVPHN(BHSPHN,21))
SET BHSTXT="Psycho/Soc/Env: "_^AUPNVPHN(BHSPHN,21)
SET BHSICL=$SELECT(BHSDCL=34:34,1:24)+1
DO PRTTXT
+8 IF $DATA(^AUPNVPHN(BHSPHN,22))
SET BHSTXT="NSG Dx: "_^AUPNVPHN(BHSPHN,22)
SET BHSICL=$SELECT(BHSDCL=34:34,1:24)+1
DO PRTTXT
+9 IF $DATA(^AUPNVPHN(BHSPHN,23))
SET BHSTXT="Short Term Goals: "_^AUPNVPHN(BHSPHN,23)
SET BHSICL=$SELECT(BHSDCL=34:34,1:24)+1
DO PRTTXT
+10 IF $DATA(^AUPNVPHN(BHSPHN,24))
SET BHSTXT="Long Term Goals: "_^AUPNVPHN(BHSPHN,24)
SET BHSICL=$SELECT(BHSDCL=34:34,1:24)+1
DO PRTTXT
+11 QUIT
+12 ;
DETAIL ; ********** PHN OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 NEW BHSPAT,BHSN,BHSNTE,BHSQ,BHSTXT,X
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVSIT("AA",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 SET BHSPVD=0
+8 SET BHSPFN=""
+9 FOR BHSIVD=0:0
SET BHSIVD=$ORDER(^AUPNVSIT("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+10 DO ONEVST
+11 IF $DATA(GMTSQIT)
QUIT
+12 IF (BHSDAT'=BHSPVD)&BHSDTU
SET GMTSNDM=GMTSNDM-BHSDTU
SET BHSPVD=BHSDAT
+13 QUIT
End DoDot:1
IF GMTSNDM=0!($DATA(GMTSQIT))
QUIT
+14 ;
CLEAN ; <CLEANUP>
+1 KILL BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSPFN,BHSSCL,BHSMTX,BHSMOD,BHSPVD,BHSOVT,BHSNDT,BHSCLI,BHSPDN,BHSICD,BHSICL,BHSNRQ,BHSPHN
+2 KILL BHSNFL,BHSNSH,BHSCCL,BHSNAB,BHSVSC,BHSITE,BHSQIT,BHSDCL,Y
+3 QUIT
+4 ;
ONEVST ;
+1 SET BHSCCL=""
+2 SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+3 SET BHSDTU=0
SET BHSNDT=(BHSDAT'=BHSPVD)
+4 SET BHSVDF=""
FOR BHSQ=0:0
SET BHSVDF=$ORDER(^AUPNVSIT("AA",BHSPAT,BHSIVD,BHSVDF))
IF BHSVDF=""
QUIT
Begin DoDot:1
+5 SET BHSSCL=""
+6 SET BHSN=^AUPNVSIT(BHSVDF,0)
+7 IF '$PIECE(BHSN,U,9)
QUIT
+8 IF $PIECE(BHSN,U,11)
QUIT
+9 IF '$DATA(^AUPNVPHN("AD",BHSVDF))
QUIT
+10 SET GMTSNDM=GMTSNDM-1
+11 DO GETCLN
+12 DO GETSITEV^BHSUTL
DO DSPVIS
+13 DO GOALS(BHSVDF)
+14 IF $DATA(GMTSQIT)
QUIT
+15 QUIT
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+16 QUIT
PRTTXT ;Print text
+1 NEW BHSQ
+2 IF '$DATA(BHSNTE)
SET BHSNTE=""
+3 SET BHSDLT=1
SET BHSILN=IOM-BHSICL-1
+4 FOR BHSQ=0:0
DO PRTTXT1
IF BHSTXT=""
QUIT
DO PRTTXT2
+5 KILL BHSNTE
+6 KILL BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
+7 QUIT
PRTTXT1 ;
+1 IF ($LENGTH(BHSTXT)+2)<255
SET BHSTXT=$SELECT(BHSTXT]"":BHSTXT,1:"")
SET BHSNRQ=""
+2 IF BHSNTE]""&(($LENGTH(BHSTXT)+2)<255)
SET BHSTXT=BHSTXT_BHSNTE
SET BHSNTE=""
+3 QUIT
PRTTXT2 DO GETFRAG
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE ?BHSICL
WRITE BHSF,!
SET BHSICL=BHSICL+BHSDLT
SET BHSILN=BHSILN-BHSDLT
SET BHSDLT=0
+1 QUIT
GETFRAG IF $LENGTH(BHSTXT)<BHSILN
SET BHSF=BHSTXT
SET BHSTXT=""
QUIT
+1 FOR BHSC=BHSILN:-1:0
IF $EXTRACT(BHSTXT,BHSC)=" "
QUIT
+2 IF BHSC=0
SET BHSC=BHSILN
+3 SET BHSF=$EXTRACT(BHSTXT,1,BHSC-1)
SET BHSTXT=$EXTRACT(BHSTXT,BHSC+1,255)
+4 QUIT
