APCHS2E.m

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