APCHS2E ; IHS/CMI/LAB -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
SKIN ; ******************* SKIN TESTS - ALL * 9000010.12 *******
; <SETUP>
Q:'$D(^AUPNVSK("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
S APCHST="" F APCHSQ=0:0 S APCHST=$O(^AUPNVSK("AA",APCHSPAT,APCHST)) Q:APCHST="" S APCHSTX=$P(^AUTTSK(APCHST,0),U,1),APCHSTL=$L(APCHSTX) X APCHSCKP Q:$D(APCHSQIT) D SKDSP
; <CLEANUP>
;now display ST refusals
S APCHST="SKIN TEST",APCHSFN=9999999.28 D DISPREF^APCHS3C
K APCHST,APCHSFN
SKINX K APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,X,Y
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
Q
SKDSP W ! X APCHSCKP Q:$D(APCHSQIT) W APCHSTX S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVSK("AA",APCHSPAT,APCHST,APCHSIVD)) Q:APCHSIVD="" D SKDSP1
Q
SKDSP1 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVSK("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D SKDSP2
Q
SKDSP2 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
Q:'$D(^AUPNVSK(APCHSDFN,0))
S APCHSVDF=$P(^AUPNVSK(APCHSDFN,0),U,3) D GETSITEV^APCHSUTL S APCHSITE=APCHSNSH
S APCHSRDG=$P(^AUPNVSK(APCHSDFN,0),U,5)
I APCHSRDG]"" S APCHSRDG=$J(APCHSRDG,2)_" mm"
I APCHSRDG="" S APCHSRDG=$P(^AUPNVSK(APCHSDFN,0),U,4) I APCHSRDG]"" S APCHSRDG=" "_$$VAL^XBDIQ1(9000010.12,APCHSDFN,.04)
I APCHSRDG="" S APCHSRDG="unrep"
X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG APCHSTX W ?15,APCHSDAT,?24,APCHSRDG,?40,APCHSITE,!
Q
;
;
SKIN3 ; ******************* SKIN TESTS - LAST 3 OF EACH * 9000010.12 *******
; <SETUP>
Q:'$D(^AUPNVSK("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
S APCHST="" F APCHSQ=0:0 S APCHST=$O(^AUPNVSK("AA",APCHSPAT,APCHST)) Q:APCHST="" S APCHSTX=$P(^AUTTSK(APCHST,0),U,1),APCHSTL=$L(APCHSTX) X APCHSCKP Q:$D(APCHSQIT) D SKDSP3
; <CLEANUP>
;now display ST refusals
S APCHST="SKIN TEST",APCHSFN=9999999.28 D DISPREF^APCHS3C
K APCHST,APCHSFN
SKIN3X K APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,APCHSCNT,APCHS,X,Y
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
Q
SKDSP3 ;get skin type
S APCHSCNT=0
W ! X APCHSCKP Q:$D(APCHSQIT) W APCHSTX S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVSK("AA",APCHSPAT,APCHST,APCHSIVD)) S APCHSCNT=APCHSCNT+1 Q:APCHSIVD=""!(APCHSCNT>3) D SKDSP13
Q
SKDSP13 ;get skin test DFN
S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVSK("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN)) Q:'APCHSDFN!(APCHSCNT>3) D SKDSP23
Q
SKDSP23 ;compile data & display skin test
S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
Q:'$D(^AUPNVSK(APCHSDFN,0))
S APCHSVDF=$P(^AUPNVSK(APCHSDFN,0),U,3) D GETSITEV^APCHSUTL S APCHSITE=APCHSNSH
S APCHSRDG=$P(^AUPNVSK(APCHSDFN,0),U,5)
I APCHSRDG]"" S APCHSRDG=$J(APCHSRDG,2)_" mm"
I APCHSRDG="" S APCHSRDG=$P(^AUPNVSK(APCHSDFN,0),U,4) I APCHSRDG]"" S APCHSRDG=" "_$$VAL^XBDIQ1(9000010.12,APCHSDFN,.04)
I APCHSRDG="" S APCHSRDG="unrep"
X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG APCHSTX W ?15,APCHSDAT,?24,APCHSRDG,?40,APCHSITE,!
Q
APCHS2E ; IHS/CMI/LAB -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
SKIN ; ******************* SKIN TESTS - ALL * 9000010.12 *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVSK("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 SET APCHST=""
FOR APCHSQ=0:0
SET APCHST=$ORDER(^AUPNVSK("AA",APCHSPAT,APCHST))
IF APCHST=""
QUIT
SET APCHSTX=$PIECE(^AUTTSK(APCHST,0),U,1)
SET APCHSTL=$LENGTH(APCHSTX)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
DO SKDSP
+6 ; <CLEANUP>
+7 ;now display ST refusals
+8 SET APCHST="SKIN TEST"
SET APCHSFN=9999999.28
DO DISPREF^APCHS3C
+9 KILL APCHST,APCHSFN
SKINX KILL APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,X,Y
+1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
+2 QUIT
SKDSP WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSTX
SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVSK("AA",APCHSPAT,APCHST,APCHSIVD))
IF APCHSIVD=""
QUIT
DO SKDSP1
+1 QUIT
SKDSP1 SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+1 SET APCHSDFN=0
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNVSK("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
DO SKDSP2
+2 QUIT
SKDSP2 SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+1 IF '$DATA(^AUPNVSK(APCHSDFN,0))
QUIT
+2 SET APCHSVDF=$PIECE(^AUPNVSK(APCHSDFN,0),U,3)
DO GETSITEV^APCHSUTL
SET APCHSITE=APCHSNSH
+3 SET APCHSRDG=$PIECE(^AUPNVSK(APCHSDFN,0),U,5)
+4 IF APCHSRDG]""
SET APCHSRDG=$JUSTIFY(APCHSRDG,2)_" mm"
+5 IF APCHSRDG=""
SET APCHSRDG=$PIECE(^AUPNVSK(APCHSDFN,0),U,4)
IF APCHSRDG]""
SET APCHSRDG=" "_$$VAL^XBDIQ1(9000010.12,APCHSDFN,.04)
+6 IF APCHSRDG=""
SET APCHSRDG="unrep"
+7 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE APCHSTX
WRITE ?15,APCHSDAT,?24,APCHSRDG,?40,APCHSITE,!
+8 QUIT
+9 ;
+10 ;
SKIN3 ; ******************* SKIN TESTS - LAST 3 OF EACH * 9000010.12 *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVSK("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 SET APCHST=""
FOR APCHSQ=0:0
SET APCHST=$ORDER(^AUPNVSK("AA",APCHSPAT,APCHST))
IF APCHST=""
QUIT
SET APCHSTX=$PIECE(^AUTTSK(APCHST,0),U,1)
SET APCHSTL=$LENGTH(APCHSTX)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
DO SKDSP3
+6 ; <CLEANUP>
+7 ;now display ST refusals
+8 SET APCHST="SKIN TEST"
SET APCHSFN=9999999.28
DO DISPREF^APCHS3C
+9 KILL APCHST,APCHSFN
SKIN3X KILL APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,APCHSCNT,APCHS,X,Y
+1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
+2 QUIT
SKDSP3 ;get skin type
+1 SET APCHSCNT=0
+2 WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSTX
SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVSK("AA",APCHSPAT,APCHST,APCHSIVD))
SET APCHSCNT=APCHSCNT+1
IF APCHSIVD=""!(APCHSCNT>3)
QUIT
DO SKDSP13
+3 QUIT
SKDSP13 ;get skin test DFN
+1 SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+2 SET APCHSDFN=0
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNVSK("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN))
IF 'APCHSDFN!(APCHSCNT>3)
QUIT
DO SKDSP23
+3 QUIT
SKDSP23 ;compile data & display skin test
+1 SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+2 IF '$DATA(^AUPNVSK(APCHSDFN,0))
QUIT
+3 SET APCHSVDF=$PIECE(^AUPNVSK(APCHSDFN,0),U,3)
DO GETSITEV^APCHSUTL
SET APCHSITE=APCHSNSH
+4 SET APCHSRDG=$PIECE(^AUPNVSK(APCHSDFN,0),U,5)
+5 IF APCHSRDG]""
SET APCHSRDG=$JUSTIFY(APCHSRDG,2)_" mm"
+6 IF APCHSRDG=""
SET APCHSRDG=$PIECE(^AUPNVSK(APCHSDFN,0),U,4)
IF APCHSRDG]""
SET APCHSRDG=" "_$$VAL^XBDIQ1(9000010.12,APCHSDFN,.04)
+7 IF APCHSRDG=""
SET APCHSRDG="unrep"
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE APCHSTX
WRITE ?15,APCHSDAT,?24,APCHSRDG,?40,APCHSITE,!
+9 QUIT
