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 ;
