BHSHOS.m

BHSHOS ;IHS/CIA/MGH - Health Summary for hospitalization encounters ;17-Mar-2006 10:36;MGH

 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006

 ;===================================================================

 ;Taken from APCHS2C

 ; IHS/TUCSON/LAB - PART 2C OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;

 ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997

 ;VA verision of IHS health summary component for hospitalization encounters

INPT ; ********** HOSPITALIZATION ENCOUNTERS * 9000010/900010.07 **********

 ; <SETUP>

 N BHSPAT,BHSQ,BHSNTE

 S BHSPAT=DFN

 Q:'$D(^AUPNVSIT("AAH",BHSPAT))

 D CKP^GMTSUP Q:$D(GMTSQIT)

 ; <DISPLAY>

 S BHSPVD=0

 S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVSIT("AAH",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM)  D

 .D ONEDATE Q:$D(GMTSQIT)  S:BHSDAT'=BHSPVD GMTSNDM=GMTSNDM-1,BHSPVD=BHSDAT Q:GMTSNDM=0

 ; <CLEANUP>

INPTX K BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSFO,BHSMTX,BHSMOD,BHSPVD,BHSHDN,BHSDDC,BHSCDN,BHSICD,BHSICL,BHSN,BHSNRQ,BHSPDN,BHSVTP

 K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,X

 Q

ONEDATE S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X S BHSDTU=(BHSDAT=BHSPVD)

 S BHSVDF="" F BHSQ=0:0 S BHSVDF=$O(^AUPNVSIT("AAH",BHSPAT,BHSIVD,BHSVDF)) Q:BHSVDF=""  S BHSN=^AUPNVSIT(BHSVDF,0) D GETSITEV^BHSUTL D:"H"[BHSVSC HOSP Q:$D(GMTSQIT)

 Q

 ;

HOSP ;

 Q:$P(BHSN,U,9)=0!($P(BHSN,U,11)=1)

 S BHSVTP=$P(BHSN,U,3)

 S BHSDTU=1

 S BHSFAC=BHSNSH

 S BHSDDC="?"

 I BHSVTP'="C" S BHSHDN=$O(^AUPNVINP("AD",BHSVDF,0)) I BHSHDN S X=+^AUPNVINP(BHSHDN,0) D REGDT4^GMTSU S BHSDDC=X

 I BHSVTP="C" S BHSCDN=$O(^AUPNVCHS("AD",BHSVDF,0)) I BHSCDN S X=$P(^AUPNVCHS(BHSCDN,0),U,7) D REGDT4^GMTSU S BHSDDC=X

 D CKP^GMTSUP Q:$D(GMTSQIT)  D IHDR

 S BHSPDN="" F BHSQ=0:0 S BHSPDN=$O(^AUPNVPOV("AD",BHSVDF,BHSPDN)) Q:'BHSPDN  S BHSN=^AUPNVPOV(BHSPDN,0) D DSPPOV

 W:$X ?33,"<no visit data>",!

 Q

 ;

DSPPOV S BHSICD=$P(BHSN,U,1) D GETICDDX^BHSUTL

 S BHSNRQ=$P(BHSN,U,4)

 D GETNARR^BHSUTL

 S BHSMOD=$P(BHSN,U,6)

 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 ***"

 D CKP^GMTSUP Q:$D(GMTSQIT)  D:GMTSNPG IHDR S BHSICL=33 S:0 BHSICD=BHSVSC_":"_BHSICD D PRTICD^BHSUTL

 Q

 ;

IHDR W BHSDAT,"-",BHSDDC,?18,BHSFAC

 Q

BHSHOS    ;IHS/CIA/MGH - Health Summary for hospitalization encounters ;17-Mar-2006 10:36;MGH

 +1       ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006

 +2       ;===================================================================

 +3       ;Taken from APCHS2C

 +4       ; IHS/TUCSON/LAB - PART 2C OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;

 +5       ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997

 +6       ;VA verision of IHS health summary component for hospitalization encounters

INPT      ; ********** HOSPITALIZATION ENCOUNTERS * 9000010/900010.07 **********

 +1       ; <SETUP>

 +2        NEW BHSPAT,BHSQ,BHSNTE

 +3        SET BHSPAT=DFN

 +4        IF '$DATA(^AUPNVSIT("AAH",BHSPAT))

               QUIT 

 +5        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

 +6       ; <DISPLAY>

 +7        SET BHSPVD=0

 +8        SET BHSIVD=""

           FOR BHSQ=0:0

               SET BHSIVD=$ORDER(^AUPNVSIT("AAH",BHSPAT,BHSIVD))

               IF BHSIVD=""!(BHSIVD>GMTSDLM)

                   QUIT 

               Begin DoDot:1

 +9                DO ONEDATE

                   IF $DATA(GMTSQIT)

                       QUIT 

                   IF BHSDAT'=BHSPVD

                       SET GMTSNDM=GMTSNDM-1

                       SET BHSPVD=BHSDAT

                   IF GMTSNDM=0

                       QUIT 

               End DoDot:1

 +10      ; <CLEANUP>

INPTX      KILL BHSIVD,BHSDTU,BHSDAT,BHSVDF,BHSFAC,BHSFO,BHSMTX,BHSMOD,BHSPVD,BHSHDN,BHSDDC,BHSCDN,BHSICD,BHSICL,BHSN,BHSNRQ,BHSPDN,BHSVTP

 +1        KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,X

 +2        QUIT 

ONEDATE    SET X=-BHSIVD\1+9999999

           DO REGDT4^GMTSU

           SET BHSDAT=X

           SET BHSDTU=(BHSDAT=BHSPVD)

 +1        SET BHSVDF=""

           FOR BHSQ=0:0

               SET BHSVDF=$ORDER(^AUPNVSIT("AAH",BHSPAT,BHSIVD,BHSVDF))

               IF BHSVDF=""

                   QUIT 

               SET BHSN=^AUPNVSIT(BHSVDF,0)

               DO GETSITEV^BHSUTL

               IF "H"[BHSVSC

                   DO HOSP

               IF $DATA(GMTSQIT)

                   QUIT 

 +2        QUIT 

 +3       ;

HOSP      ;

 +1        IF $PIECE(BHSN,U,9)=0!($PIECE(BHSN,U,11)=1)

               QUIT 

 +2        SET BHSVTP=$PIECE(BHSN,U,3)

 +3        SET BHSDTU=1

 +4        SET BHSFAC=BHSNSH

 +5        SET BHSDDC="?"

 +6        IF BHSVTP'="C"

               SET BHSHDN=$ORDER(^AUPNVINP("AD",BHSVDF,0))

               IF BHSHDN

                   SET X=+^AUPNVINP(BHSHDN,0)

                   DO REGDT4^GMTSU

                   SET BHSDDC=X

 +7        IF BHSVTP="C"

               SET BHSCDN=$ORDER(^AUPNVCHS("AD",BHSVDF,0))

               IF BHSCDN

                   SET X=$PIECE(^AUPNVCHS(BHSCDN,0),U,7)

                   DO REGDT4^GMTSU

                   SET BHSDDC=X

 +8        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           DO IHDR

 +9        SET BHSPDN=""

           FOR BHSQ=0:0

               SET BHSPDN=$ORDER(^AUPNVPOV("AD",BHSVDF,BHSPDN))

               IF 'BHSPDN

                   QUIT 

               SET BHSN=^AUPNVPOV(BHSPDN,0)

               DO DSPPOV

 +10       IF $X

               WRITE ?33,"<no visit data>",!

 +11       QUIT 

 +12      ;

DSPPOV     SET BHSICD=$PIECE(BHSN,U,1)

           DO GETICDDX^BHSUTL

 +1        SET BHSNRQ=$PIECE(BHSN,U,4)

 +2        DO GETNARR^BHSUTL

 +3        SET BHSMOD=$PIECE(BHSN,U,6)

 +4        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

 +5        IF $DATA(^AUPNVCHS("AD",BHSVDF))

               SET BHSNTE="*** CHS ***"

 +6        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           IF GMTSNPG

               DO IHDR

           SET BHSICL=33

           IF 0

               SET BHSICD=BHSVSC_":"_BHSICD

           DO PRTICD^BHSUTL

 +7        QUIT 

 +8       ;

IHDR       WRITE BHSDAT,"-",BHSDDC,?18,BHSFAC

 +1        QUIT