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
