APCHS11A.m

APCHS11A ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;

 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 ;IHS/CMI/LAB - uncommented age limit on pap smear

 ;

 ;cmi/anch/maw 8/28/2007 code set versioning in PAP

 ;

 ; ******************** SURVEILLANCE - HARD CODE ********************

ENTB ;ENDEMIC TB, I.E. ALASKA

 Q:APCHSAGE'<35

 K APCHSKDT

 I $D(^ATXAX("B","SURVEILLANCE TB")) S APCHSURD=$O(^ATXAX("B","SURVEILLANCE TB","")) Q:$D(^ATXPAT(APCHSURD,11,APCHSPAT))

 S APCHSDIS="TB SKIN TEST"

 S APCHSKN=24 D SKINTEST D:APCHSKND MULTSKIN ;MONO-VAC

 S APCHSKN=21 D SKINTEST D:APCHSKND MULTSKIN ;PPD

 S APCHSKN=20 D SKINTEST D:APCHSKND MULTSKIN ;TINE

 I '$D(APCHSKDT),APCHSAGE'>(10/12) S X1=APCHSDOB,X2=300 D C^%DTC S Y=X X APCHSCVD S APCHSDUE=Y,APCHSDAT="" D DISPLAY^APCHS11 Q

 I '$D(APCHSKDT) S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D DISPLAY^APCHS11 Q

 S APCHSIVD=$O(APCHSKDT("")),APCHSKD=APCHSKDT(APCHSIVD),APCHSDAT=$P($P(^AUPNVSIT($P(^AUPNVSK(APCHSKD,0),U,3),0),U),".")

 I $P(^AUPNVSK(APCHSKD,0),U,4)'="P" S APCHSINT=365 D GETDATE^APCHS11,COMPARE^APCHS11,DISPLAY^APCHS11

 Q

 ;

NONTB ;NONENDEMIC TB AREAS

 Q:APCHSAGE'<13

 K APCHSKDT

 I $D(^ATXAX("B","SURVEILLANCE TB")) S APCHSURD=$O(^ATXAX("B","SURVEILLANCE TB","")) Q:$D(^ATXPAT(APCHSURD,11,APCHSPAT))

 S APCHSDIS="TB SKIN TEST"

 S APCHSKN=24 D SKINTEST D:APCHSKND MULTSKIN ;MONO-VAC

 S APCHSKN=21 D SKINTEST D:APCHSKND MULTSKIN ;PPD

 S APCHSKN=20 D SKINTEST D:APCHSKND MULTSKIN ;TINE

 I '$D(APCHSKDT),APCHSAGE'>1 S X1=APCHSDOB,X2=360 D C^%DTC S Y=X X APCHSCVD S APCHSDUE=Y,APCHSDAT="" D DISPLAY^APCHS11 Q

 I '$D(APCHSKDT) S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D DISPLAY^APCHS11 Q

 S APCHSIVD=$O(APCHSKDT("")),APCHSKD=APCHSKDT(APCHSIVD)

 I $P(^AUPNVSK(APCHSKD,0),U,4)="P" Q

 D PASTAGE^APCHS11

 I APCHSOLD<(9/12) S APCHSDUE="MAY BE DUE NOW" D GETDATE^APCHS11,DISPLAY^APCHS11 Q

 I APCHSAGE'<5,APCHSOLD<4 S APCHSDUE="MAY BE DUE NOW" D GETDATE^APCHS11,DISPLAY^APCHS11

 Q

 ;

MULTSKIN ;

 K APCHSDT

 S APCHSDT=$O(^AUPNVSK("AA",APCHSPAT,APCHSKND,"")) I APCHSDT S APCHSKDT(APCHSDT)=$O(^(APCHSDT,""))

 Q

 ;

PAP ;

 K APCHSTP

 Q:APCHSAGE<18!(APCHSEX="M")  ;IHS/CMI/LAB - uncommented

 K APCHSEXD,APCHSDF1

 Q:APCHSEX="M"

 K APCHSTEX

 S APCHSTXN=0

 S APCHSBWR=0 S:$D(X) APCHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(APCHSAVX) X=APCHSAVX K APCHSAVX I $T S APCHSBWR=1

 I APCHSBWR,$D(^BWP(APCHSPAT,0)) S APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)=$$CNEED^BWUTL1(APCHSPAT) I APCHSTEX(1)="UNKNOWN" K APCHSTEX(1) S APCHSTXN=0

 ;cmi/anch/maw 8/27/2007 mods for code set versioning

 N APCHSVDT

 ;I $D(^AUPNVPRC("AC",APCHSPAT)) S APCHSDF=0 F APCHSLP=0:0 S APCHSDF=$O(^AUPNVPRC("AC",APCHSPAT,APCHSDF)) Q:APCHSDF'=+APCHSDF!($D(APCHSTP))  S APCHSPRC=$P(^ICD0(+^AUPNVPRC(APCHSDF,0),0),U) D PAP2

 I $D(^AUPNVPRC("AC",APCHSPAT)) S APCHSDF=0 F APCHSLP=0:0 S APCHSDF=$O(^AUPNVPRC("AC",APCHSPAT,APCHSDF)) Q:APCHSDF'=+APCHSDF!($D(APCHSTP))  D

 .S APCHSVDT=$P(+^AUPNVSIT($P(^AUPNVPRC(APCHSDF,0),U,3),0),"."),APCHSPRC=$P($$ICDOP^ICDEX(+^AUPNVPRC(APCHSDF,0),APCHSVDT,,"I"),U,2) D PAP2

 ;cmi/anch/maw 8/27/2007 end of mods

 I $D(APCHSTP) S APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)="Pt had hysterectomy.  Pap may be necessary",APCHSTXN=APCHSTXN+1,APCHSTEX(APCHSTXN)="based on individual followup."

 K APCHSTXN

 S APCHSLAB="PAP SMEAR"

 S APCHSDIS="PAP SMEAR"

 S APCHSINT=365

 D REGLAB^APCHS11

 K APCHSBWR

 Q

 ;

PAP2 ;CHECKS TO SEE IF PATIENT HAD A HYSTERECTOMY

 S:APCHSPRC=68.3!(APCHSPRC=68.4)!(APCHSPRC=68.5)!(APCHSPRC=68.6)!(APCHSPRC=68.7)!(APCHSPRC=68.9) APCHSTP=""

 Q

 ;

BRST ;BREAST EXAM

 K APCHSEXD,APCHSDF1

 Q:APCHSAGE<20!(APCHSEX="M")

 S APCHSEXN="06"

 S APCHSDIS="BREAST EXAM"

 ;---> NEXT LINE DISPLAYS WOMEN'S HEALTH BREAST TX NEED per WOMEN'S HEALTH PACKAGE

 K APCHSTEX

 S APCHSBWR=0 S:$D(X) APCHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(APCHSAVX) X=APCHSAVX K APCHSAVX I $T S APCHSBWR=1

 I APCHSBWR,$D(^BWP(APCHSPAT,0)) S BWDFN=APCHSPAT S APCHSTEX(1)=$$BNEED^BWUTL1(APCHSPAT) K BWDFN I APCHSTEX(1)="UNKNOWN" K APCHSTEX(1)

 S APCHSINT=365

 D REGEXAM^APCHS11

 K APCHSBWR

 Q

 ;

GLUCOSE ;

 K APCHSEXD,APCHSDF1

 I $D(^ATXAX("B","SURVEILLANCE DIABETES")) S APCHSURD=$O(^ATXAX("B","SURVEILLANCE DIABETES","")) Q:$D(^ATXPAT(APCHSURD,11,APCHSPAT))

 Q:APCHSAGE'>20

 S APCHSLAB="GLUCOSE"

 D LABDFN^APCHS11

 Q:'APCHSLBD

 S APCHSDIS="BLOOD GLUCOSE"

 S APCHSINT=365*2

 D REGLAB^APCHS11

 Q

 ;

PELVIC ;

 K APCHSEXD,APCHSDF1,APCHSTEX

 Q:APCHSAGE<18!(APCHSEX="M")

 S APCHSEXN="15"

 S APCHSDIS="PELVIC EXAM"

 S APCHSINT=365

 D REGEXAM^APCHS11

 Q

 ;

MAMGRAM ; MAMMOGRAM

 Q:APCHSEX="M"

 ;---> NEXT LINE DISPLAYS WOMEN'S HEALTH BREAST TX NEED per WOMEN'S HEALTH PACKAGE

 K APCHSTEX

 S APCHSBWR=0 S:$D(X) APCHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(APCHSAVX) X=APCHSAVX K APCHSAVX I $T S APCHSBWR=1

 I APCHSBWR,$D(^BWP(APCHSPAT,0)) S BWDFN=APCHSPAT S APCHSTEX(1)=$$BNEED^BWUTL1(APCHSPAT) K BWDFN I APCHSTEX(1)="UNKNOWN" K APCHSTEX(1)

 I $D(APCHSTEX(1)) G MAM1

 Q:APCHSAGE<50

 Q:APCHSAGE>69

MAM1 K APCHSMDT

 S APCHSDIS="MAMMOGRAM"

 S APCHSMAM=0 F  S APCHSMAM=$O(^RAMIS(71,"D",76090,APCHSMAM)) Q:APCHSMAM=""  D MULTMAM

 S APCHSMAM=0 F  S APCHSMAM=$O(^RAMIS(71,"D",76091,APCHSMAM)) Q:APCHSMAM=""  D MULTMAM

 S APCHSMAM=0 F  S APCHSMAM=$O(^RAMIS(71,"D",76092,APCHSMAM)) Q:APCHSMAM=""  D MULTMAM

 I '$D(APCHSMDT) S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D DISPLAY^APCHS11 Q

 S APCHSIVD=$O(APCHSMDT("")),APCHSINT=365*2

 D GETDATE^APCHS11,COMPARE^APCHS11

 S APCHSEXD=$O(^RAMIS(71,"D",76090,0)),APCHSDF1=71 D REFDF^APCHS11

 S APCHSEXD=$O(^RAMIS(71,"D",76091,0)),APCHSDF1=71 D REFDF^APCHS11

 S APCHSEXD=$O(^RAMIS(71,"D",76092,0)),APCHSDF1=71 D REFDF^APCHS11

 D DISPLAY^APCHS11

 I '$D(APCHSMDT) S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D DISPLAY^APCHS11 Q

 Q

 ;

MULTMAM ;

 K APCHSDT

 S APCHSDT=$O(^AUPNVRAD("AA",APCHSPAT,APCHSMAM,"")) I APCHSDT S APCHSMDT(APCHSDT)=$O(^(APCHSDT,""))

 Q

 ;

SKINTEST ;LOOKS UP THE DFN OF THE SKIN TEST

 S APCHSKND=$O(^AUTTSK("C",APCHSKN,""))

 Q

 ;

APCHS11A  ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;

 +1       ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 +2       ;IHS/CMI/LAB - uncommented age limit on pap smear

 +3       ;

 +4       ;cmi/anch/maw 8/28/2007 code set versioning in PAP

 +5       ;

 +6       ; ******************** SURVEILLANCE - HARD CODE ********************

ENTB      ;ENDEMIC TB, I.E. ALASKA

 +1        IF APCHSAGE'<35

               QUIT 

 +2        KILL APCHSKDT

 +3        IF $DATA(^ATXAX("B","SURVEILLANCE TB"))

               SET APCHSURD=$ORDER(^ATXAX("B","SURVEILLANCE TB",""))

               IF $DATA(^ATXPAT(APCHSURD,11,APCHSPAT))

                   QUIT 

 +4        SET APCHSDIS="TB SKIN TEST"

 +5       ;MONO-VAC

           SET APCHSKN=24

           DO SKINTEST

           IF APCHSKND

               DO MULTSKIN

 +6       ;PPD

           SET APCHSKN=21

           DO SKINTEST

           IF APCHSKND

               DO MULTSKIN

 +7       ;TINE

           SET APCHSKN=20

           DO SKINTEST

           IF APCHSKND

               DO MULTSKIN

 +8        IF '$DATA(APCHSKDT)

               IF APCHSAGE'>(10/12)

                   SET X1=APCHSDOB

                   SET X2=300

                   DO C^%DTC

                   SET Y=X

                   XECUTE APCHSCVD

                   SET APCHSDUE=Y

                   SET APCHSDAT=""

                   DO DISPLAY^APCHS11

                   QUIT 

 +9        IF '$DATA(APCHSKDT)

               SET APCHSDUE="MAY BE DUE NOW"

               SET APCHSDAT=""

               DO DISPLAY^APCHS11

               QUIT 

 +10       SET APCHSIVD=$ORDER(APCHSKDT(""))

           SET APCHSKD=APCHSKDT(APCHSIVD)

           SET APCHSDAT=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVSK(APCHSKD,0),U,3),0),U),".")

 +11       IF $PIECE(^AUPNVSK(APCHSKD,0),U,4)'="P"

               SET APCHSINT=365

               DO GETDATE^APCHS11

               DO COMPARE^APCHS11

               DO DISPLAY^APCHS11

 +12       QUIT 

 +13      ;

NONTB     ;NONENDEMIC TB AREAS

 +1        IF APCHSAGE'<13

               QUIT 

 +2        KILL APCHSKDT

 +3        IF $DATA(^ATXAX("B","SURVEILLANCE TB"))

               SET APCHSURD=$ORDER(^ATXAX("B","SURVEILLANCE TB",""))

               IF $DATA(^ATXPAT(APCHSURD,11,APCHSPAT))

                   QUIT 

 +4        SET APCHSDIS="TB SKIN TEST"

 +5       ;MONO-VAC

           SET APCHSKN=24

           DO SKINTEST

           IF APCHSKND

               DO MULTSKIN

 +6       ;PPD

           SET APCHSKN=21

           DO SKINTEST

           IF APCHSKND

               DO MULTSKIN

 +7       ;TINE

           SET APCHSKN=20

           DO SKINTEST

           IF APCHSKND

               DO MULTSKIN

 +8        IF '$DATA(APCHSKDT)

               IF APCHSAGE'>1

                   SET X1=APCHSDOB

                   SET X2=360

                   DO C^%DTC

                   SET Y=X

                   XECUTE APCHSCVD

                   SET APCHSDUE=Y

                   SET APCHSDAT=""

                   DO DISPLAY^APCHS11

                   QUIT 

 +9        IF '$DATA(APCHSKDT)

               SET APCHSDUE="MAY BE DUE NOW"

               SET APCHSDAT=""

               DO DISPLAY^APCHS11

               QUIT 

 +10       SET APCHSIVD=$ORDER(APCHSKDT(""))

           SET APCHSKD=APCHSKDT(APCHSIVD)

 +11       IF $PIECE(^AUPNVSK(APCHSKD,0),U,4)="P"

               QUIT 

 +12       DO PASTAGE^APCHS11

 +13       IF APCHSOLD<(9/12)

               SET APCHSDUE="MAY BE DUE NOW"

               DO GETDATE^APCHS11

               DO DISPLAY^APCHS11

               QUIT 

 +14       IF APCHSAGE'<5

               IF APCHSOLD<4

                   SET APCHSDUE="MAY BE DUE NOW"

                   DO GETDATE^APCHS11

                   DO DISPLAY^APCHS11

 +15       QUIT 

 +16      ;

MULTSKIN  ;

 +1        KILL APCHSDT

 +2        SET APCHSDT=$ORDER(^AUPNVSK("AA",APCHSPAT,APCHSKND,""))

           IF APCHSDT

               SET APCHSKDT(APCHSDT)=$ORDER(^(APCHSDT,""))

 +3        QUIT 

 +4       ;

PAP       ;

 +1        KILL APCHSTP

 +2       ;IHS/CMI/LAB - uncommented

           IF APCHSAGE<18!(APCHSEX="M")

               QUIT 

 +3        KILL APCHSEXD,APCHSDF1

 +4        IF APCHSEX="M"

               QUIT 

 +5        KILL APCHSTEX

 +6        SET APCHSTXN=0

 +7        SET APCHSBWR=0

           IF $DATA(X)

               SET APCHSAVX=X

           SET X="BWUTL1"

           XECUTE ^%ZOSF("TEST")

           IF $DATA(APCHSAVX)

               SET X=APCHSAVX

           KILL APCHSAVX

           IF $TEST

               SET APCHSBWR=1

 +8        IF APCHSBWR

               IF $DATA(^BWP(APCHSPAT,0))

                   SET APCHSTXN=APCHSTXN+1

                   SET APCHSTEX(APCHSTXN)=$$CNEED^BWUTL1(APCHSPAT)

                   IF APCHSTEX(1)="UNKNOWN"

                       KILL APCHSTEX(1)

                       SET APCHSTXN=0

 +9       ;cmi/anch/maw 8/27/2007 mods for code set versioning

 +10       NEW APCHSVDT

 +11      ;I $D(^AUPNVPRC("AC",APCHSPAT)) S APCHSDF=0 F APCHSLP=0:0 S APCHSDF=$O(^AUPNVPRC("AC",APCHSPAT,APCHSDF)) Q:APCHSDF'=+APCHSDF!($D(APCHSTP))  S APCHSPRC=$P(^ICD0(+^AUPNVPRC(APCHSDF,0),0),U) D PAP2

 +12       IF $DATA(^AUPNVPRC("AC",APCHSPAT))

               SET APCHSDF=0

               FOR APCHSLP=0:0

                   SET APCHSDF=$ORDER(^AUPNVPRC("AC",APCHSPAT,APCHSDF))

                   IF APCHSDF'=+APCHSDF!($DATA(APCHSTP))

                       QUIT 

                   Begin DoDot:1

 +13                   SET APCHSVDT=$PIECE(+^AUPNVSIT($PIECE(^AUPNVPRC(APCHSDF,0),U,3),0),".")

                       SET APCHSPRC=$PIECE($$ICDOP^ICDEX(+^AUPNVPRC(APCHSDF,0),APCHSVDT,,"I"),U,2)

                       DO PAP2

                   End DoDot:1

 +14      ;cmi/anch/maw 8/27/2007 end of mods

 +15       IF $DATA(APCHSTP)

               SET APCHSTXN=APCHSTXN+1

               SET APCHSTEX(APCHSTXN)="Pt had hysterectomy.  Pap may be necessary"

               SET APCHSTXN=APCHSTXN+1

               SET APCHSTEX(APCHSTXN)="based on individual followup."

 +16       KILL APCHSTXN

 +17       SET APCHSLAB="PAP SMEAR"

 +18       SET APCHSDIS="PAP SMEAR"

 +19       SET APCHSINT=365

 +20       DO REGLAB^APCHS11

 +21       KILL APCHSBWR

 +22       QUIT 

 +23      ;

PAP2      ;CHECKS TO SEE IF PATIENT HAD A HYSTERECTOMY

 +1        IF APCHSPRC=68.3!(APCHSPRC=68.4)!(APCHSPRC=68.5)!(APCHSPRC=68.6)!(APCHSPRC=68.7)!(APCHSPRC=68.9)

               SET APCHSTP=""

 +2        QUIT 

 +3       ;

BRST      ;BREAST EXAM

 +1        KILL APCHSEXD,APCHSDF1

 +2        IF APCHSAGE<20!(APCHSEX="M")

               QUIT 

 +3        SET APCHSEXN="06"

 +4        SET APCHSDIS="BREAST EXAM"

 +5       ;---> NEXT LINE DISPLAYS WOMEN'S HEALTH BREAST TX NEED per WOMEN'S HEALTH PACKAGE

 +6        KILL APCHSTEX

 +7        SET APCHSBWR=0

           IF $DATA(X)

               SET APCHSAVX=X

           SET X="BWUTL1"

           XECUTE ^%ZOSF("TEST")

           IF $DATA(APCHSAVX)

               SET X=APCHSAVX

           KILL APCHSAVX

           IF $TEST

               SET APCHSBWR=1

 +8        IF APCHSBWR

               IF $DATA(^BWP(APCHSPAT,0))

                   SET BWDFN=APCHSPAT

                   SET APCHSTEX(1)=$$BNEED^BWUTL1(APCHSPAT)

                   KILL BWDFN

                   IF APCHSTEX(1)="UNKNOWN"

                       KILL APCHSTEX(1)

 +9        SET APCHSINT=365

 +10       DO REGEXAM^APCHS11

 +11       KILL APCHSBWR

 +12       QUIT 

 +13      ;

GLUCOSE   ;

 +1        KILL APCHSEXD,APCHSDF1

 +2        IF $DATA(^ATXAX("B","SURVEILLANCE DIABETES"))

               SET APCHSURD=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",""))

               IF $DATA(^ATXPAT(APCHSURD,11,APCHSPAT))

                   QUIT 

 +3        IF APCHSAGE'>20

               QUIT 

 +4        SET APCHSLAB="GLUCOSE"

 +5        DO LABDFN^APCHS11

 +6        IF 'APCHSLBD

               QUIT 

 +7        SET APCHSDIS="BLOOD GLUCOSE"

 +8        SET APCHSINT=365*2

 +9        DO REGLAB^APCHS11

 +10       QUIT 

 +11      ;

PELVIC    ;

 +1        KILL APCHSEXD,APCHSDF1,APCHSTEX

 +2        IF APCHSAGE<18!(APCHSEX="M")

               QUIT 

 +3        SET APCHSEXN="15"

 +4        SET APCHSDIS="PELVIC EXAM"

 +5        SET APCHSINT=365

 +6        DO REGEXAM^APCHS11

 +7        QUIT 

 +8       ;

MAMGRAM   ; MAMMOGRAM

 +1        IF APCHSEX="M"

               QUIT 

 +2       ;---> NEXT LINE DISPLAYS WOMEN'S HEALTH BREAST TX NEED per WOMEN'S HEALTH PACKAGE

 +3        KILL APCHSTEX

 +4        SET APCHSBWR=0

           IF $DATA(X)

               SET APCHSAVX=X

           SET X="BWUTL1"

           XECUTE ^%ZOSF("TEST")

           IF $DATA(APCHSAVX)

               SET X=APCHSAVX

           KILL APCHSAVX

           IF $TEST

               SET APCHSBWR=1

 +5        IF APCHSBWR

               IF $DATA(^BWP(APCHSPAT,0))

                   SET BWDFN=APCHSPAT

                   SET APCHSTEX(1)=$$BNEED^BWUTL1(APCHSPAT)

                   KILL BWDFN

                   IF APCHSTEX(1)="UNKNOWN"

                       KILL APCHSTEX(1)

 +6        IF $DATA(APCHSTEX(1))

               GOTO MAM1

 +7        IF APCHSAGE<50

               QUIT 

 +8        IF APCHSAGE>69

               QUIT 

MAM1       KILL APCHSMDT

 +1        SET APCHSDIS="MAMMOGRAM"

 +2        SET APCHSMAM=0

           FOR 

               SET APCHSMAM=$ORDER(^RAMIS(71,"D",76090,APCHSMAM))

               IF APCHSMAM=""

                   QUIT 

               DO MULTMAM

 +3        SET APCHSMAM=0

           FOR 

               SET APCHSMAM=$ORDER(^RAMIS(71,"D",76091,APCHSMAM))

               IF APCHSMAM=""

                   QUIT 

               DO MULTMAM

 +4        SET APCHSMAM=0

           FOR 

               SET APCHSMAM=$ORDER(^RAMIS(71,"D",76092,APCHSMAM))

               IF APCHSMAM=""

                   QUIT 

               DO MULTMAM

 +5        IF '$DATA(APCHSMDT)

               SET APCHSDUE="MAY BE DUE NOW"

               SET APCHSDAT=""

               DO DISPLAY^APCHS11

               QUIT 

 +6        SET APCHSIVD=$ORDER(APCHSMDT(""))

           SET APCHSINT=365*2

 +7        DO GETDATE^APCHS11

           DO COMPARE^APCHS11

 +8        SET APCHSEXD=$ORDER(^RAMIS(71,"D",76090,0))

           SET APCHSDF1=71

           DO REFDF^APCHS11

 +9        SET APCHSEXD=$ORDER(^RAMIS(71,"D",76091,0))

           SET APCHSDF1=71

           DO REFDF^APCHS11

 +10       SET APCHSEXD=$ORDER(^RAMIS(71,"D",76092,0))

           SET APCHSDF1=71

           DO REFDF^APCHS11

 +11       DO DISPLAY^APCHS11

 +12       IF '$DATA(APCHSMDT)

               SET APCHSDUE="MAY BE DUE NOW"

               SET APCHSDAT=""

               DO DISPLAY^APCHS11

               QUIT 

 +13       QUIT 

 +14      ;

MULTMAM   ;

 +1        KILL APCHSDT

 +2        SET APCHSDT=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHSMAM,""))

           IF APCHSDT

               SET APCHSMDT(APCHSDT)=$ORDER(^(APCHSDT,""))

 +3        QUIT 

 +4       ;

SKINTEST  ;LOOKS UP THE DFN OF THE SKIN TEST

 +1        SET APCHSKND=$ORDER(^AUTTSK("C",APCHSKN,""))

 +2        QUIT 

 +3       ;