BHSSKIN.m

BHSSKIN ; IHS/TUCSON/LAB -- SUMMARY PRODUCTION COMPONENTS ;27-May-2008 14:22;MGH

 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2**;March 17,2006

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

 ;Taken from APCHS2E

 ;IHS RPMS/PCC Health Summary;**11,14**;JUN 24, 1997

 ;

SKIN ; ******************* EP; SKIN TESTS - ALL * 9000010.12 *******

 ; <SETUP>

 N BHSPAT

 S BHSPAT=DFN

 Q:'$D(^AUPNVSK("AA",BHSPAT))

 D CKP^GMTSUP Q:$D(GMTSQIT)

 ; <DISPLAY>

 S BHST="" F BHSQ=0:0 S BHST=$O(^AUPNVSK("AA",BHSPAT,BHST)) Q:BHST=""  S BHSTX=$P(^AUTTSK(BHST,0),U,1),BHSTL=$L(BHSTX) D CKP^GMTSUP Q:$D(GMTSQIT)  D SKDSP

 ; <CLEANUP>

SKINX K BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,X,Y

 K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE

 Q

SKDSP W ! D CKP^GMTSUP Q:$D(GMTSQIT)  W BHSTX S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVSK("AA",BHSPAT,BHST,BHSIVD)) Q:BHSIVD=""  D SKDSP1

 Q

SKDSP1 S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X

 S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVSK("AA",BHSPAT,BHST,BHSIVD,BHSDFN)) Q:'BHSDFN  D SKDSP2

 Q

SKDSP2 S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X

 Q:'$D(^AUPNVSK(BHSDFN,0))

 S BHSVDF=$P(^AUPNVSK(BHSDFN,0),U,3) D GETSITEV^BHSUTL S BHSITE=BHSNSH

 S BHSRDG=$P(^AUPNVSK(BHSDFN,0),U,5)

 I BHSRDG]"" S BHSRDG=$J(BHSRDG,2)_" mm"

 I BHSRDG="" S BHSRDG=$P(^AUPNVSK(BHSDFN,0),U,4) I BHSRDG]"" S BHSRDG=" "_$$VAL^XBDIQ1(9000010.12,BHSDFN,.04)

 I BHSRDG="" S BHSRDG="unrep"

 D CKP^GMTSUP Q:$D(GMTSQIT)  W:GMTSNPG BHSTX W ?15,BHSDAT,?26,BHSRDG,?42,BHSITE,!

 Q

 ;

 ;

SKIN3 ; ******************* ;EP SKIN TESTS - LAST 3 OF EACH * 9000010.12 *******

 ; <SETUP>

 Q:'$D(^AUPNVSK("AA",BHSPAT))

 D CKP^GMTSUP Q:$D(GMTSQIT)

 ; <DISPLAY>

 S BHST="" F BHSQ=0:0 S BHST=$O(^AUPNVSK("AA",BHSPAT,BHST)) Q:BHST=""  S BHSTX=$P(^AUTTSK(BHST,0),U,1),BHSTL=$L(BHSTX) D CKP^GMTSUP Q:$D(GMTSQIT)  D SKDSP3

 ; <CLEANUP>

SKIN3X K BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,BHSCNT,BHS,X,Y

 K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSQ

 Q

SKDSP3 ;get skin type

 S BHSCNT=0

 W ! D CKP^GMTSUP Q:$D(GMTSQIT)  W BHSTX S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVSK("AA",BHSPAT,BHST,BHSIVD)) S BHSCNT=BHSCNT+1 Q:BHSIVD=""!(BHSCNT>3)  D SKDSP13

 Q

SKDSP13 ;get skin test DFN

 S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X

 S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVSK("AA",BHSPAT,BHST,BHSIVD,BHSDFN)) Q:'BHSDFN!(BHSCNT>3)  D SKDSP23

 Q

SKDSP23 ;compile data & display skin test

 S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X

 Q:'$D(^AUPNVSK(BHSDFN,0))

 S BHSVDF=$P(^AUPNVSK(BHSDFN,0),U,3) D GETSITEV^BHSUTL S BHSITE=BHSNSH

 S BHSRDG=$P(^AUPNVSK(BHSDFN,0),U,5)

 I BHSRDG]"" S BHSRDG=$J(BHSRDG,2)_" mm"

 I BHSRDG="" S BHSRDG=$P(^AUPNVSK(BHSDFN,0),U,4) I BHSRDG]"" S BHSRDG=" "_$$VAL^XBDIQ1(9000010.12,BHSDFN,.04)

 I BHSRDG="" S BHSRDG="unrep"

 D CKP^GMTSUP Q:$D(GMTSQIT)  W:GMTSNPG BHSTX W ?15,BHSDAT,?24,BHSRDG,?40,BHSITE,!

 Q

BHSSKIN   ; IHS/TUCSON/LAB -- SUMMARY PRODUCTION COMPONENTS ;27-May-2008 14:22;MGH

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

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

 +3       ;Taken from APCHS2E

 +4       ;IHS RPMS/PCC Health Summary;**11,14**;JUN 24, 1997

 +5       ;

SKIN      ; ******************* EP; SKIN TESTS - ALL * 9000010.12 *******

 +1       ; <SETUP>

 +2        NEW BHSPAT

 +3        SET BHSPAT=DFN

 +4        IF '$DATA(^AUPNVSK("AA",BHSPAT))

               QUIT 

 +5        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

 +6       ; <DISPLAY>

 +7        SET BHST=""

           FOR BHSQ=0:0

               SET BHST=$ORDER(^AUPNVSK("AA",BHSPAT,BHST))

               IF BHST=""

                   QUIT 

               SET BHSTX=$PIECE(^AUTTSK(BHST,0),U,1)

               SET BHSTL=$LENGTH(BHSTX)

               DO CKP^GMTSUP

               IF $DATA(GMTSQIT)

                   QUIT 

               DO SKDSP

 +8       ; <CLEANUP>

SKINX      KILL BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,X,Y

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

 +2        QUIT 

SKDSP      WRITE !

           DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           WRITE BHSTX

           SET BHSIVD=""

           FOR BHSQ=0:0

               SET BHSIVD=$ORDER(^AUPNVSK("AA",BHSPAT,BHST,BHSIVD))

               IF BHSIVD=""

                   QUIT 

               DO SKDSP1

 +1        QUIT 

SKDSP1     SET X=-BHSIVD\1+9999999

           DO REGDT4^GMTSU

           SET BHSDAT=X

 +1        SET BHSDFN=0

           FOR BHSQ=0:0

               SET BHSDFN=$ORDER(^AUPNVSK("AA",BHSPAT,BHST,BHSIVD,BHSDFN))

               IF 'BHSDFN

                   QUIT 

               DO SKDSP2

 +2        QUIT 

SKDSP2     SET X=-BHSIVD\1+9999999

           DO REGDT4^GMTSU

           SET BHSDAT=X

 +1        IF '$DATA(^AUPNVSK(BHSDFN,0))

               QUIT 

 +2        SET BHSVDF=$PIECE(^AUPNVSK(BHSDFN,0),U,3)

           DO GETSITEV^BHSUTL

           SET BHSITE=BHSNSH

 +3        SET BHSRDG=$PIECE(^AUPNVSK(BHSDFN,0),U,5)

 +4        IF BHSRDG]""

               SET BHSRDG=$JUSTIFY(BHSRDG,2)_" mm"

 +5        IF BHSRDG=""

               SET BHSRDG=$PIECE(^AUPNVSK(BHSDFN,0),U,4)

               IF BHSRDG]""

                   SET BHSRDG=" "_$$VAL^XBDIQ1(9000010.12,BHSDFN,.04)

 +6        IF BHSRDG=""

               SET BHSRDG="unrep"

 +7        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           IF GMTSNPG

               WRITE BHSTX

           WRITE ?15,BHSDAT,?26,BHSRDG,?42,BHSITE,!

 +8        QUIT 

 +9       ;

 +10      ;

SKIN3     ; ******************* ;EP SKIN TESTS - LAST 3 OF EACH * 9000010.12 *******

 +1       ; <SETUP>

 +2        IF '$DATA(^AUPNVSK("AA",BHSPAT))

               QUIT 

 +3        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

 +4       ; <DISPLAY>

 +5        SET BHST=""

           FOR BHSQ=0:0

               SET BHST=$ORDER(^AUPNVSK("AA",BHSPAT,BHST))

               IF BHST=""

                   QUIT 

               SET BHSTX=$PIECE(^AUTTSK(BHST,0),U,1)

               SET BHSTL=$LENGTH(BHSTX)

               DO CKP^GMTSUP

               IF $DATA(GMTSQIT)

                   QUIT 

               DO SKDSP3

 +6       ; <CLEANUP>

SKIN3X     KILL BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,BHSCNT,BHS,X,Y

 +1        KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHSQ

 +2        QUIT 

SKDSP3    ;get skin type

 +1        SET BHSCNT=0

 +2        WRITE !

           DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           WRITE BHSTX

           SET BHSIVD=""

           FOR BHSQ=0:0

               SET BHSIVD=$ORDER(^AUPNVSK("AA",BHSPAT,BHST,BHSIVD))

               SET BHSCNT=BHSCNT+1

               IF BHSIVD=""!(BHSCNT>3)

                   QUIT 

               DO SKDSP13

 +3        QUIT 

SKDSP13   ;get skin test DFN

 +1        SET X=-BHSIVD\1+9999999

           DO REGDT4^GMTSU

           SET BHSDAT=X

 +2        SET BHSDFN=0

           FOR BHSQ=0:0

               SET BHSDFN=$ORDER(^AUPNVSK("AA",BHSPAT,BHST,BHSIVD,BHSDFN))

               IF 'BHSDFN!(BHSCNT>3)

                   QUIT 

               DO SKDSP23

 +3        QUIT 

SKDSP23   ;compile data & display skin test

 +1        SET X=-BHSIVD\1+9999999

           DO REGDT4^GMTSU

           SET BHSDAT=X

 +2        IF '$DATA(^AUPNVSK(BHSDFN,0))

               QUIT 

 +3        SET BHSVDF=$PIECE(^AUPNVSK(BHSDFN,0),U,3)

           DO GETSITEV^BHSUTL

           SET BHSITE=BHSNSH

 +4        SET BHSRDG=$PIECE(^AUPNVSK(BHSDFN,0),U,5)

 +5        IF BHSRDG]""

               SET BHSRDG=$JUSTIFY(BHSRDG,2)_" mm"

 +6        IF BHSRDG=""

               SET BHSRDG=$PIECE(^AUPNVSK(BHSDFN,0),U,4)

               IF BHSRDG]""

                   SET BHSRDG=" "_$$VAL^XBDIQ1(9000010.12,BHSDFN,.04)

 +7        IF BHSRDG=""

               SET BHSRDG="unrep"

 +8        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           IF GMTSNPG

               WRITE BHSTX

           WRITE ?15,BHSDAT,?24,BHSRDG,?40,BHSITE,!

 +9        QUIT