APCHPWH6 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
;;2.0;IHS PCC SUITE;**2,6,7,10,11**;MAY 14, 2009;Build 58
;
;EO MEASURES IN PWH
CANCER ;EP - cancer CCI measure
NEW APCHVAL,Y,APCHHD
D SUBHEAD^APCHPWHU
S APCHHD=0 ;D S^APCHPWH1("CANCER SCREENING",1)
D MAMMOGM
D PAP
D COLORECT
Q
;
MAMMOGM ;
Q:$P(^DPT(APCHSDFN,0),U,2)'="F"
Q:$$AGE^AUPNPAT(APCHSDFN)<50
Q:$$AGE^AUPNPAT(APCHSDFN)>69
S APCHVAL=$$LASTMAM^APCLAPI1(APCHSDFN)
;I 'APCHHD D S^APCHPWH1("CANCER SCREENING",1) S APCHHD=1
D S^APCHPWH1("MAMMOGRAM",1)
I APCHVAL="" D Q
.D S^APCHPWH1("No mammogram on file. It is recommended that you receive a mammogram")
.D S^APCHPWH1("every year. Ask your health care provider to order a mammogram for you.")
I $$FMDIFF^XLFDT(DT,APCHVAL)<365 D Q
.D S^APCHPWH1("Your last mammogram was on "_$$FMTE^XLFDT(APCHVAL)_". Your next mammogram will")
.D S^APCHPWH1("be due on "_$$FMTE^XLFDT($$FMADD^XLFDT(APCHVAL,365))_".")
D S^APCHPWH1("Your last mammogram was on "_$$FMTE^XLFDT(APCHVAL)_". We recommend that you")
D S^APCHPWH1("receive a mammogram every year. Ask your health care provider to order a ")
D S^APCHPWH1("mammogram for you.")
Q
;
PAP ;
Q:$P(^DPT(APCHSDFN,0),U,2)'="F"
Q:$$AGE^AUPNPAT(APCHSDFN)<19
I $$HYSTER^APCHSM04(APCHSDFN) Q
D S^APCHPWH1("PAP SMEAR",1)
S APCHVAL=$$LASTPAP^APCLAPI1(APCHSDFN)
I APCHVAL="" D Q
.D S^APCHPWH1("No Pap Smear on file. We recommend that you get a Pap Smear every 3 years.")
.D S^APCHPWH1("Ask your health care provider to order a Pap Smear for you.")
;
I $$FMDIFF^XLFDT(DT,APCHVAL)<(3*365) D Q
.D S^APCHPWH1("Your last Pap Smear was on "_$$FMTE^XLFDT(APCHVAL)_". Your next Pap Smear will")
.D S^APCHPWH1("be due on "_$$FMTE^XLFDT($$FMADD^XLFDT(APCHVAL,(3*365)))_".")
D S^APCHPWH1("Your last Pap Smear was on "_$$FMTE^XLFDT(APCHVAL)_". We recommend that you")
D S^APCHPWH1("get a Pap smear every 3 years. Ask your health care provider to order a ")
D S^APCHPWH1("Pap Smear for you.")
Q
;
COLORECT ;
Q:$$AGE^AUPNPAT(APCHSDFN)<51
Q:$$CRC(APCHSDFN)
;I 'APCHHD D S^APCHPWH1("CANCER SCREENING",1) S APCHHD=1
D S^APCHPWH1("COLON HEALTH SCREENING",1)
NEW D,Y
S D="",Y=""
S APCHVAL=$$LASTCOLO^APCLAPI(APCHSDFN,$$FMADD^XLFDT(DT,-(10*365)),DT,"D")
I APCHVAL S D=$$FMADD^XLFDT(APCHVAL,(10*365))
S APCHVAL=$$LASTFSIG^APCLAPI(APCHSDFN,$$FMADD^XLFDT(DT,-(5*365)),DT,"D")
I APCHVAL S Y=$$FMADD^XLFDT(APCHVAL,(5*365)) I Y>D S D=Y
S APCHVAL=$$LASTBE^APCLAPI4(APCHSDFN,$$FMADD^XLFDT(DT,-(10*365)),DT,"D")
I APCHVAL S Y=$$FMADD^XLFDT(APCHVAL,(10*365)) I Y>D S D=Y
S APCHVAL=$$LASTFOBT^APCLAPI3(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT,"D")
I APCHVAL S Y=$$FMADD^XLFDT(APCHVAL,365) I Y>D S D=Y
I D D COLODISP Q
D S^APCHPWH1("It is recommended that all people who are 51 years and older be screened")
D S^APCHPWH1("for colon cancer. Ask your health care provider to order a colon cancer")
D S^APCHPWH1("screening for you.")
Q
COLODISP ;
D S^APCHPWH1("You are up to date for colon cancer screening. Your next colon cancer")
D S^APCHPWH1("screening will be due on "_$$FMTE^XLFDT(D)_".")
Q
;
CRC(P) ;EP
NEW APCHX,Y,X,T
K APCHX
S Y="APCHX("
S X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(DT) S E=$$START1^APCLDF(X,Y)
I $D(APCHX(1)) Q 1 ;has a dx
S X=$$LASTCPTT^APCLAPIU(P,,DT,"BGP COLORECTAL CANCER CPTS","D")
I X]"" Q 1
S X=$$LASTPRCT^APCLAPIU(P,,DT,"BGP TOTAL CHOLECTOMY PROCS","D")
I X Q 1
S X=$$LASTCPTT^APCLAPIU(P,,DT,"BGP TOTAL CHOLECTOMY CPTS","D")
I X Q 1
I $$PLTAX^APCHSMU(P,"BGP COLORECTAL CANCER DXS") Q 1
Q 0
;
CKD(P) ;EP - Does patient have chronic kidney disease (CKD)?
NEW T,APCHLLAB,I,X
;get last serum creatinine value
;S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0)),$O(^ATXAX("B","BGP CREATININE LOINC")))
;I $$SEX^AUPNPAT(APCHSDFN)="F",APCHLLAB>1.3 Q 1
;I $$SEX^AUPNPAT(APCHSDFN)="M",APCHLLAB>1.5 Q 1
;get last urine protein value
S T=$O(^ATXAX("B","APCH CKD DXS",0))
S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="I",$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXAPI(Y,T,9) S I=1
I I Q 1
S T=$$LASTDX^APCHSMU2(P,"APCH CKD DXS",$$FMADD^XLFDT(DT,-(365*1)),DT)
I T Q 1
S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0)),$O(^ATXAX("B","DM AUDIT P/C RATIO LOINC")))
I +APCHLLAB>200 Q 1
S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT 24HR URINE PROTEIN",0)))
I +APCHLLAB>300 Q 1
;get last A/C ratio value
S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT QUANT UACR",0)))
I +APCHLLAB>30 Q 1
;get estimated GFR
S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0)),$O(^ATXAX("B","BGP ESTIMATED GFR LOINC")),"ESTIMATED GFR")
I +APCHLLAB,APCHLLAB<60 Q 1
Q ""
;
LAB(P,T,LT,LN) ;EP
I '$G(LT) S LT=""
S LN=$G(LN)
NEW D,V,G,X,J S (D,G)=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G) D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G) D
...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=Y Q
...I LN]"",$$VAL^XBDIQ1(9000010.09,Y,.01)=LN S G=Y Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S G=Y
...Q
..Q
.Q
I 'G Q ""
Q $P(^AUPNVLAB(G,0),U,4)
;
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
;
NEW APCHY,APCHV,%,LDFE,PROV,D,V,G
S LDFE="",%=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) S LDFE=$P(APCHY(1),U)
;now check any clinic 65 or prov 33/25
K APCHY,APCHV
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"APCHY(")
;reorder by date
S %=0 F S %=$O(APCHY(%)) Q:%'=+% S APCHV(9999999-$P(APCHY(%),U),$P(APCHY(%),U,5))=""
S (D,V)=0,G="" F S D=$O(APCHV(D)) Q:D'=+D!(G) S V=0 F S V=$O(APCHV(D,V)) Q:V'=+V!(G) D
.S PROV=$$PRIMPROV^APCLV(V,"D") I (PROV=33!(PROV=25)),'$$DNKA^APCHS9B4(V) S G=9999999-D Q
.S PROV=$$CLINIC^APCLV(V,"C") I PROV=65!(PROV="B7"),'$$DNKA^APCHS9B4(V) S G=9999999-D
I G,G>LDFE S LDFE=G
Q LDFE
LAB30 ;EP - all labs in past 100 days
NEW APCHLAB,APCHX,X,L,N,R,APCHL
S APCHLAB="APCHLAB"
D ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,,,,.APCHLAB)
Q:'$D(APCHLAB)
D SUBHEAD^APCHPWHU
D S^APCHPWH1("RECENT LAB RESULTS")
D WRITET^APCHPWHU("RECENT LAB RESULTS")
S X="LABORATORY TEST",$E(X,32)="RESULT",$E(X,52)="REFERENCE RANGE",$E(X,68)="DATE" D S^APCHPWH1(X)
S APCHX=0 F S APCHX=$O(APCHLAB(APCHX)) Q:APCHX'=+APCHX D
.S APCHL=$P(APCHLAB(APCHX),U,4)
.Q:$P(^AUPNVLAB(APCHL,0),U,4)="" ;no result - this is pending
.Q:$P(^AUPNVLAB(APCHL,0),U,4)="canc" ;CANCELLED TEST
.S N=$P($G(^AUPNVLAB(APCHL,11)),U,1) ;UNITS
.I $$UP^XLFSTR($P(^AUPNVLAB(APCHL,0),U,4))["REJECTED TEST" Q
.S R=""
.I $P($G(^AUPNVLAB(APCHL,11)),U,4)]"",$P($G(^AUPNVLAB(APCHL,11)),U,5)]"" S R=$P(^AUPNVLAB(APCHL,11),U,4)_"-"_$P(^AUPNVLAB(APCHL,11),U,5)
.S X=$E($P(APCHLAB(APCHX),U,2),1,30),$E(X,32)=$P(APCHLAB(APCHX),U,3)_" "_N,$E(X,52)=R,$E(X,68)=$$FMTE^XLFDT($P(APCHLAB(APCHX),U,1))
.D S^APCHPWH1(X)
.;DISPLAY COMMENTS? YES/NO
.Q:'$P(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,4)
.;display comments (21 multiple using ^DIWP with a length of 65, indented to column 8
.K ^UTILITY($J,"W")
.S APCMZ=0
.S DIWL=1,DIWR=65 F S APCMZ=$O(^AUPNVLAB(APCHL,21,APCMZ)) Q:APCMZ'=+APCMZ D
..S X=^AUPNVLAB(APCHL,21,APCMZ,0) I X]"" D ^DIWP
..Q
.S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S X="",$E(X,8)=^UTILITY($J,"W",DIWL,Z,0) D S^APCHPWH1(X)
.K ^UTILITY($J,"W")
Q
PENDLAB ;
NEW APCHLRDF,APCHMIEN,APCHIEN,APCHLABS,APCHTIEN,APCHCNT
S APCHLRDF=$G(^DPT(DFN,"LR"))
Q:'APCHLRDF ;NO LRDFN TO USE FOR LOOKUP
Q:'$D(^LRO(69,"D",APCHLRDF)) ;no orders in LRO(69 for this LRDFN
K APCHLABS
S APCHCNT=0
;gather up order date (.01 field and test names in APCHLABS)
S APCHIEN=$$FMADD^XLFDT(DT,-184) F S APCHIEN=$O(^LRO(69,"D",APCHLRDF,APCHIEN)) Q:APCHIEN="" D
.S APCHMIEN=0 F S APCHMIEN=$O(^LRO(69,"D",APCHLRDF,APCHIEN,APCHMIEN)) Q:APCHMIEN="" D
..;now loop through tests to see if any not accessioned
..S APCHTIEN=0 F S APCHTIEN=$O(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN)) Q:APCHTIEN'=+APCHTIEN D
...Q:$P($G(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN,0)),U,3) ;has accession date so not a pending order
...S APCHCNT=APCHCNT+1,APCHLABS(APCHCNT)=$P(^LRO(69,APCHIEN,0),U,1)_U_$P(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN,0),U,1)
Q:'$D(APCHLABS) ;no pending labs so don't bother with displaying hte component.
D SUBHEAD^APCHPWHU
D S^APCHPWH1("PENDING LAB ORDERS")
D WRITET^APCHPWHU("PENDING LABS")
S X="",$E(X,5)="LABORATORY TEST",$E(X,40)="DATE ORDERED" D S^APCHPWH1(X)
S APCHCNT=0 F S APCHCNT=$O(APCHLABS(APCHCNT)) Q:APCHCNT="" D
.S X="",$E(X,5)=$P(^LAB(60,$P(APCHLABS(APCHCNT),U,2),0),U,1),$E(X,40)=$$FMTE^XLFDT($P(APCHLABS(APCHCNT),U,1)) D S^APCHPWH1(X)
Q
;
PROCS ;EP - CALLED FROM PROCEDURES COMPONENT OF THE PWH
;
HOS ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******
NEW APCHHOSA,APCHHOSC,APCHSCNT,APCHSIVD,APCHSICD,APCHSN,APCHSDAT,APCHCODE,APCHDES,APCHSDAT,APCHSCVD,APCHSIEN
NEW APCHCPTI,V,AJPCHT,Y
K APCHHOSA,APCHHOSC
I '$D(^AUPNVPRC("AC",APCHSDFN)),'$D(^AUPNVCPT("AC",APCHSDFN)),'$D(^AUPNVTC("AC",APCHSDFN)) G HOSX
S APCHSCNT=0
;
S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVPRC("AA",APCHSDFN,APCHSIVD)) Q:'APCHSIVD D
.S APCHSIEN=0 F S APCHSIEN=$O(^AUPNVPRC("AA",APCHSDFN,APCHSIVD,APCHSIEN)) Q:'APCHSIEN D
..S APCHSICD=$P(^AUPNVPRC(APCHSIEN,0),U)
..S APCHSN=^AUPNVPRC(APCHSIEN,0)
..D HOSCHK Q:APCHSICD=""
..S APCHSCNT=APCHSCNT+1
..;S APCHCSVD=+^AUPNVSIT($P(APCHSN,U,3),0)\1
..S X=$$ICDOP^ICDEX($P(APCHSN,U,1),+^AUPNVSIT($P(APCHSN,U,3),0)\1,,"I")
..S APCHCODE=$P(X,U,2),APCHDES=$P(X,U,5)
..S APCHSDAT=""
..S Y=$P(APCHSN,U,6) I Y]"" S APCHSDAT=$$FMTE^XLFDT(Y)
..I APCHSDAT="" S Y=$P(APCHSN,U,3),Y=+^AUPNVSIT(Y,0)\1 S APCHSDAT=$$FMTE^XLFDT(Y)
..S APCHHOSA(APCHSIVD,"PRC",APCHSIEN)=APCHSDAT_U_APCHDES_U_APCHCODE
;now go through v cpt
S APCHT=$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
S APCHCPTI=0 F S APCHCPTI=$O(^AUPNVCPT("AA",APCHSDFN,APCHCPTI)) Q:APCHCPTI'=+APCHCPTI D
.I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component
.S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVCPT("AA",APCHSDFN,APCHCPTI,APCHSIVD)) Q:APCHSIVD="" D
..S APCHSIEN=0 F S APCHSIEN=$O(^AUPNVCPT("AA",APCHSDFN,APCHCPTI,APCHSIVD,APCHSIEN)) Q:APCHSIEN'=+APCHSIEN D
...S Y=(9999999-APCHSIVD) S APCHSDAT=$$FMTE^XLFDT(Y)
...S APCHSN=^AUPNVCPT(APCHSIEN,0)
...S APCHSCNT=APCHSCNT+1
...S APCHDES=$P($$CPT^ICPTCOD($P(APCHSN,U,1),Y),U,3) ;cmi/anch/maw 8/28/2007 code set versioning
...S APCHCODE=$P($$CPT^ICPTCOD($P(APCHSN,U,1),Y),U,2)
...S APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=APCHSDAT_U_APCHDES_U_APCHCODE
...S APCHHOSC(APCHSIVD,"CPT",$P(^ICPT($P(APCHSN,U,1),0),U,1))=""
;now get all tran codes hcpcs
S APCHSIEN=0 F S APCHSIEN=$O(^AUPNVTC("AC",APCHSDFN,APCHSIEN)) Q:APCHSIEN="" D
.Q:'$D(^AUPNVTC(APCHSIEN))
.S V=$P(^AUPNVTC(APCHSIEN,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S (APCHSDAT,V)=$P($P(^AUPNVSIT(V,0),U),".")
.S APCHSIVD=9999999-V
.S APCHCPTI=$P(^AUPNVTC(APCHSIEN,0),U,7)
.Q:APCHCPTI=""
.I '$$ICD^ATXAPI(APCHCPTI,APCHT,1) Q ;not a cpt wanted on this component
.Q:$D(APCHHOSC(APCHSIVD,"CPT",$P(^ICPT(APCHCPTI,0),U,1)))
.S APCHDES=$P($$CPT^ICPTCOD(APCHCPTI,APCHSDAT),U,3)
.S APCHCODE=$P($$CPT^ICPTCOD(APCHCPTI,APCHSDAT),U,2)
.S APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=$$FMTE^XLFDT(APCHSDAT)_U_APCHDES_U_APCHCODE
.S APCHSCNT=APCHSCNT+1
;now display the procedures/cpt codes
Q:'APCHSCNT
D SUBHEAD^APCHPWHU
D S^APCHPWH1("PROCEDURES")
D WRITET^APCHPWHU("PROCEDURES")
S APCHSIVD=0 F S APCHSIVD=$O(APCHHOSA(APCHSIVD)) Q:APCHSIVD="" D
. S APCHIEN=0 F S APCHIEN=$O(APCHHOSA(APCHSIVD,"PRC",APCHIEN)) Q:APCHIEN'=+APCHIEN D
.. S APCHDES=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,2)
.. S APCHSDAT=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,1)
.. S APCHCODE=$P(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,3)
.. S X="",$E(X,1)=APCHDES,$E(X,60)=APCHSDAT
.. D S^APCHPWH1(X)
. S APCHIEN=0 F S APCHIEN=$O(APCHHOSA(APCHSIVD,"CPT",APCHIEN)) Q:APCHIEN'=+APCHIEN!($D(APCHSQIT)) D
.. S APCHDES=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,2)
.. S APCHSDAT=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,1)
.. S APCHCODE=$P(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,3)
.. S X="",$E(X,1)=APCHDES,$E(X,60)=APCHSDAT
.. D S^APCHPWH1(X)
HOSX ;
K APCHHOSA,APCHHOSC
Q
HOSCHK ;
S APCHSCOD=$P($$ICDOP^ICDEX(APCHSICD,,,"I"),U,2) ;cmi/anch/maw CSV
I $$ICD^ATXAPI(APCHSICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S APCHSICD=""
Q
APCHPWH6 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
+1 ;;2.0;IHS PCC SUITE;**2,6,7,10,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;EO MEASURES IN PWH
CANCER ;EP - cancer CCI measure
+1 NEW APCHVAL,Y,APCHHD
+2 DO SUBHEAD^APCHPWHU
+3 ;D S^APCHPWH1("CANCER SCREENING",1)
SET APCHHD=0
+4 DO MAMMOGM
+5 DO PAP
+6 DO COLORECT
+7 QUIT
+8 ;
MAMMOGM ;
+1 IF $PIECE(^DPT(APCHSDFN,0),U,2)'="F"
QUIT
+2 IF $$AGE^AUPNPAT(APCHSDFN)<50
QUIT
+3 IF $$AGE^AUPNPAT(APCHSDFN)>69
QUIT
+4 SET APCHVAL=$$LASTMAM^APCLAPI1(APCHSDFN)
+5 ;I 'APCHHD D S^APCHPWH1("CANCER SCREENING",1) S APCHHD=1
+6 DO S^APCHPWH1("MAMMOGRAM",1)
+7 IF APCHVAL=""
Begin DoDot:1
+8 DO S^APCHPWH1("No mammogram on file. It is recommended that you receive a mammogram")
+9 DO S^APCHPWH1("every year. Ask your health care provider to order a mammogram for you.")
End DoDot:1
QUIT
+10 IF $$FMDIFF^XLFDT(DT,APCHVAL)<365
Begin DoDot:1
+11 DO S^APCHPWH1("Your last mammogram was on "_$$FMTE^XLFDT(APCHVAL)_". Your next mammogram will")
+12 DO S^APCHPWH1("be due on "_$$FMTE^XLFDT($$FMADD^XLFDT(APCHVAL,365))_".")
End DoDot:1
QUIT
+13 DO S^APCHPWH1("Your last mammogram was on "_$$FMTE^XLFDT(APCHVAL)_". We recommend that you")
+14 DO S^APCHPWH1("receive a mammogram every year. Ask your health care provider to order a ")
+15 DO S^APCHPWH1("mammogram for you.")
+16 QUIT
+17 ;
PAP ;
+1 IF $PIECE(^DPT(APCHSDFN,0),U,2)'="F"
QUIT
+2 IF $$AGE^AUPNPAT(APCHSDFN)<19
QUIT
+3 IF $$HYSTER^APCHSM04(APCHSDFN)
QUIT
+4 DO S^APCHPWH1("PAP SMEAR",1)
+5 SET APCHVAL=$$LASTPAP^APCLAPI1(APCHSDFN)
+6 IF APCHVAL=""
Begin DoDot:1
+7 DO S^APCHPWH1("No Pap Smear on file. We recommend that you get a Pap Smear every 3 years.")
+8 DO S^APCHPWH1("Ask your health care provider to order a Pap Smear for you.")
End DoDot:1
QUIT
+9 ;
+10 IF $$FMDIFF^XLFDT(DT,APCHVAL)<(3*365)
Begin DoDot:1
+11 DO S^APCHPWH1("Your last Pap Smear was on "_$$FMTE^XLFDT(APCHVAL)_". Your next Pap Smear will")
+12 DO S^APCHPWH1("be due on "_$$FMTE^XLFDT($$FMADD^XLFDT(APCHVAL,(3*365)))_".")
End DoDot:1
QUIT
+13 DO S^APCHPWH1("Your last Pap Smear was on "_$$FMTE^XLFDT(APCHVAL)_". We recommend that you")
+14 DO S^APCHPWH1("get a Pap smear every 3 years. Ask your health care provider to order a ")
+15 DO S^APCHPWH1("Pap Smear for you.")
+16 QUIT
+17 ;
COLORECT ;
+1 IF $$AGE^AUPNPAT(APCHSDFN)<51
QUIT
+2 IF $$CRC(APCHSDFN)
QUIT
+3 ;I 'APCHHD D S^APCHPWH1("CANCER SCREENING",1) S APCHHD=1
+4 DO S^APCHPWH1("COLON HEALTH SCREENING",1)
+5 NEW D,Y
+6 SET D=""
SET Y=""
+7 SET APCHVAL=$$LASTCOLO^APCLAPI(APCHSDFN,$$FMADD^XLFDT(DT,-(10*365)),DT,"D")
+8 IF APCHVAL
SET D=$$FMADD^XLFDT(APCHVAL,(10*365))
+9 SET APCHVAL=$$LASTFSIG^APCLAPI(APCHSDFN,$$FMADD^XLFDT(DT,-(5*365)),DT,"D")
+10 IF APCHVAL
SET Y=$$FMADD^XLFDT(APCHVAL,(5*365))
IF Y>D
SET D=Y
+11 SET APCHVAL=$$LASTBE^APCLAPI4(APCHSDFN,$$FMADD^XLFDT(DT,-(10*365)),DT,"D")
+12 IF APCHVAL
SET Y=$$FMADD^XLFDT(APCHVAL,(10*365))
IF Y>D
SET D=Y
+13 SET APCHVAL=$$LASTFOBT^APCLAPI3(APCHSDFN,$$FMADD^XLFDT(DT,-365),DT,"D")
+14 IF APCHVAL
SET Y=$$FMADD^XLFDT(APCHVAL,365)
IF Y>D
SET D=Y
+15 IF D
DO COLODISP
QUIT
+16 DO S^APCHPWH1("It is recommended that all people who are 51 years and older be screened")
+17 DO S^APCHPWH1("for colon cancer. Ask your health care provider to order a colon cancer")
+18 DO S^APCHPWH1("screening for you.")
+19 QUIT
COLODISP ;
+1 DO S^APCHPWH1("You are up to date for colon cancer screening. Your next colon cancer")
+2 DO S^APCHPWH1("screening will be due on "_$$FMTE^XLFDT(D)_".")
+3 QUIT
+4 ;
CRC(P) ;EP
+1 NEW APCHX,Y,X,T
+2 KILL APCHX
+3 SET Y="APCHX("
+4 SET X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(X,Y)
+5 ;has a dx
IF $DATA(APCHX(1))
QUIT 1
+6 SET X=$$LASTCPTT^APCLAPIU(P,,DT,"BGP COLORECTAL CANCER CPTS","D")
+7 IF X]""
QUIT 1
+8 SET X=$$LASTPRCT^APCLAPIU(P,,DT,"BGP TOTAL CHOLECTOMY PROCS","D")
+9 IF X
QUIT 1
+10 SET X=$$LASTCPTT^APCLAPIU(P,,DT,"BGP TOTAL CHOLECTOMY CPTS","D")
+11 IF X
QUIT 1
+12 IF $$PLTAX^APCHSMU(P,"BGP COLORECTAL CANCER DXS")
QUIT 1
+13 QUIT 0
+14 ;
CKD(P) ;EP - Does patient have chronic kidney disease (CKD)?
+1 NEW T,APCHLLAB,I,X
+2 ;get last serum creatinine value
+3 ;S APCHLLAB=$$LAB(P,$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0)),$O(^ATXAX("B","BGP CREATININE LOINC")))
+4 ;I $$SEX^AUPNPAT(APCHSDFN)="F",APCHLLAB>1.3 Q 1
+5 ;I $$SEX^AUPNPAT(APCHSDFN)="M",APCHLLAB>1.5 Q 1
+6 ;get last urine protein value
+7 SET T=$ORDER(^ATXAX("B","APCH CKD DXS",0))
+8 SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="I"
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXAPI(Y,T,9)
SET I=1
+9 IF I
QUIT 1
+10 SET T=$$LASTDX^APCHSMU2(P,"APCH CKD DXS",$$FMADD^XLFDT(DT,-(365*1)),DT)
+11 IF T
QUIT 1
+12 SET APCHLLAB=$$LAB(P,$ORDER(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0)),$ORDER(^ATXAX("B","DM AUDIT P/C RATIO LOINC")))
+13 IF +APCHLLAB>200
QUIT 1
+14 SET APCHLLAB=$$LAB(P,$ORDER(^ATXLAB("B","DM AUDIT 24HR URINE PROTEIN",0)))
+15 IF +APCHLLAB>300
QUIT 1
+16 ;get last A/C ratio value
+17 SET APCHLLAB=$$LAB(P,$ORDER(^ATXLAB("B","DM AUDIT QUANT UACR",0)))
+18 IF +APCHLLAB>30
QUIT 1
+19 ;get estimated GFR
+20 SET APCHLLAB=$$LAB(P,$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0)),$ORDER(^ATXAX("B","BGP ESTIMATED GFR LOINC")),"ESTIMATED GFR")
+21 IF +APCHLLAB
IF APCHLLAB<60
QUIT 1
+22 QUIT ""
+23 ;
LAB(P,T,LT,LN) ;EP
+1 IF '$GET(LT)
SET LT=""
+2 SET LN=$GET(LN)
+3 NEW D,V,G,X,J
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+5 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+6 IF $DATA(^ATXLAB(T,21,"B",X))
IF $PIECE(^AUPNVLAB(Y,0),U,4)]""
SET G=Y
QUIT
+7 IF LN]""
IF $$VAL^XBDIQ1(9000010.09,Y,.01)=LN
SET G=Y
QUIT
+8 IF 'LT
QUIT
+9 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+10 IF '$$LOINC(J,LT)
QUIT
+11 SET G=Y
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 IF 'G
QUIT ""
+16 QUIT $PIECE(^AUPNVLAB(G,0),U,4)
+17 ;
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
+7 ;
+1 NEW APCHY,APCHV,%,LDFE,PROV,D,V,G
+2 SET LDFE=""
SET %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"APCHY(")
+3 IF $DATA(APCHY(1))
SET LDFE=$PIECE(APCHY(1),U)
+4 ;now check any clinic 65 or prov 33/25
+5 KILL APCHY,APCHV
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"APCHY(")
+7 ;reorder by date
+8 SET %=0
FOR
SET %=$ORDER(APCHY(%))
IF %'=+%
QUIT
SET APCHV(9999999-$PIECE(APCHY(%),U),$PIECE(APCHY(%),U,5))=""
+9 SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(APCHV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(APCHV(D,V))
IF V'=+V!(G)
QUIT
Begin DoDot:1
+10 SET PROV=$$PRIMPROV^APCLV(V,"D")
IF (PROV=33!(PROV=25))
IF '$$DNKA^APCHS9B4(V)
SET G=9999999-D
QUIT
+11 SET PROV=$$CLINIC^APCLV(V,"C")
IF PROV=65!(PROV="B7")
IF '$$DNKA^APCHS9B4(V)
SET G=9999999-D
End DoDot:1
+12 IF G
IF G>LDFE
SET LDFE=G
+13 QUIT LDFE
LAB30 ;EP - all labs in past 100 days
+1 NEW APCHLAB,APCHX,X,L,N,R,APCHL
+2 SET APCHLAB="APCHLAB"
+3 DO ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(DT,-100),DT,,,,.APCHLAB)
+4 IF '$DATA(APCHLAB)
QUIT
+5 DO SUBHEAD^APCHPWHU
+6 DO S^APCHPWH1("RECENT LAB RESULTS")
+7 DO WRITET^APCHPWHU("RECENT LAB RESULTS")
+8 SET X="LABORATORY TEST"
SET $EXTRACT(X,32)="RESULT"
SET $EXTRACT(X,52)="REFERENCE RANGE"
SET $EXTRACT(X,68)="DATE"
DO S^APCHPWH1(X)
+9 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHLAB(APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+10 SET APCHL=$PIECE(APCHLAB(APCHX),U,4)
+11 ;no result - this is pending
IF $PIECE(^AUPNVLAB(APCHL,0),U,4)=""
QUIT
+12 ;CANCELLED TEST
IF $PIECE(^AUPNVLAB(APCHL,0),U,4)="canc"
QUIT
+13 ;UNITS
SET N=$PIECE($GET(^AUPNVLAB(APCHL,11)),U,1)
+14 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(APCHL,0),U,4))["REJECTED TEST"
QUIT
+15 SET R=""
+16 IF $PIECE($GET(^AUPNVLAB(APCHL,11)),U,4)]""
IF $PIECE($GET(^AUPNVLAB(APCHL,11)),U,5)]""
SET R=$PIECE(^AUPNVLAB(APCHL,11),U,4)_"-"_$PIECE(^AUPNVLAB(APCHL,11),U,5)
+17 SET X=$EXTRACT($PIECE(APCHLAB(APCHX),U,2),1,30)
SET $EXTRACT(X,32)=$PIECE(APCHLAB(APCHX),U,3)_" "_N
SET $EXTRACT(X,52)=R
SET $EXTRACT(X,68)=$$FMTE^XLFDT($PIECE(APCHLAB(APCHX),U,1))
+18 DO S^APCHPWH1(X)
+19 ;DISPLAY COMMENTS? YES/NO
+20 IF '$PIECE(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,4)
QUIT
+21 ;display comments (21 multiple using ^DIWP with a length of 65, indented to column 8
+22 KILL ^UTILITY($JOB,"W")
+23 SET APCMZ=0
+24 SET DIWL=1
SET DIWR=65
FOR
SET APCMZ=$ORDER(^AUPNVLAB(APCHL,21,APCMZ))
IF APCMZ'=+APCMZ
QUIT
Begin DoDot:2
+25 SET X=^AUPNVLAB(APCHL,21,APCMZ,0)
IF X]""
DO ^DIWP
+26 QUIT
End DoDot:2
+27 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
SET X=""
SET $EXTRACT(X,8)=^UTILITY($JOB,"W",DIWL,Z,0)
DO S^APCHPWH1(X)
+28 KILL ^UTILITY($JOB,"W")
End DoDot:1
+29 QUIT
PENDLAB ;
+1 NEW APCHLRDF,APCHMIEN,APCHIEN,APCHLABS,APCHTIEN,APCHCNT
+2 SET APCHLRDF=$GET(^DPT(DFN,"LR"))
+3 ;NO LRDFN TO USE FOR LOOKUP
IF 'APCHLRDF
QUIT
+4 ;no orders in LRO(69 for this LRDFN
IF '$DATA(^LRO(69,"D",APCHLRDF))
QUIT
+5 KILL APCHLABS
+6 SET APCHCNT=0
+7 ;gather up order date (.01 field and test names in APCHLABS)
+8 SET APCHIEN=$$FMADD^XLFDT(DT,-184)
FOR
SET APCHIEN=$ORDER(^LRO(69,"D",APCHLRDF,APCHIEN))
IF APCHIEN=""
QUIT
Begin DoDot:1
+9 SET APCHMIEN=0
FOR
SET APCHMIEN=$ORDER(^LRO(69,"D",APCHLRDF,APCHIEN,APCHMIEN))
IF APCHMIEN=""
QUIT
Begin DoDot:2
+10 ;now loop through tests to see if any not accessioned
+11 SET APCHTIEN=0
FOR
SET APCHTIEN=$ORDER(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN))
IF APCHTIEN'=+APCHTIEN
QUIT
Begin DoDot:3
+12 ;has accession date so not a pending order
IF $PIECE($GET(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN,0)),U,3)
QUIT
+13 SET APCHCNT=APCHCNT+1
SET APCHLABS(APCHCNT)=$PIECE(^LRO(69,APCHIEN,0),U,1)_U_$PIECE(^LRO(69,APCHIEN,1,APCHMIEN,2,APCHTIEN,0),U,1)
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;no pending labs so don't bother with displaying hte component.
IF '$DATA(APCHLABS)
QUIT
+15 DO SUBHEAD^APCHPWHU
+16 DO S^APCHPWH1("PENDING LAB ORDERS")
+17 DO WRITET^APCHPWHU("PENDING LABS")
+18 SET X=""
SET $EXTRACT(X,5)="LABORATORY TEST"
SET $EXTRACT(X,40)="DATE ORDERED"
DO S^APCHPWH1(X)
+19 SET APCHCNT=0
FOR
SET APCHCNT=$ORDER(APCHLABS(APCHCNT))
IF APCHCNT=""
QUIT
Begin DoDot:1
+20 SET X=""
SET $EXTRACT(X,5)=$PIECE(^LAB(60,$PIECE(APCHLABS(APCHCNT),U,2),0),U,1)
SET $EXTRACT(X,40)=$$FMTE^XLFDT($PIECE(APCHLABS(APCHCNT),U,1))
DO S^APCHPWH1(X)
End DoDot:1
+21 QUIT
+22 ;
PROCS ;EP - CALLED FROM PROCEDURES COMPONENT OF THE PWH
+1 ;
HOS ; HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) & V CPT *******
+1 NEW APCHHOSA,APCHHOSC,APCHSCNT,APCHSIVD,APCHSICD,APCHSN,APCHSDAT,APCHCODE,APCHDES,APCHSDAT,APCHSCVD,APCHSIEN
+2 NEW APCHCPTI,V,AJPCHT,Y
+3 KILL APCHHOSA,APCHHOSC
+4 IF '$DATA(^AUPNVPRC("AC",APCHSDFN))
IF '$DATA(^AUPNVCPT("AC",APCHSDFN))
IF '$DATA(^AUPNVTC("AC",APCHSDFN))
GOTO HOSX
+5 SET APCHSCNT=0
+6 ;
+7 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVPRC("AA",APCHSDFN,APCHSIVD))
IF 'APCHSIVD
QUIT
Begin DoDot:1
+8 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^AUPNVPRC("AA",APCHSDFN,APCHSIVD,APCHSIEN))
IF 'APCHSIEN
QUIT
Begin DoDot:2
+9 SET APCHSICD=$PIECE(^AUPNVPRC(APCHSIEN,0),U)
+10 SET APCHSN=^AUPNVPRC(APCHSIEN,0)
+11 DO HOSCHK
IF APCHSICD=""
QUIT
+12 SET APCHSCNT=APCHSCNT+1
+13 ;S APCHCSVD=+^AUPNVSIT($P(APCHSN,U,3),0)\1
+14 SET X=$$ICDOP^ICDEX($PIECE(APCHSN,U,1),+^AUPNVSIT($PIECE(APCHSN,U,3),0)\1,,"I")
+15 SET APCHCODE=$PIECE(X,U,2)
SET APCHDES=$PIECE(X,U,5)
+16 SET APCHSDAT=""
+17 SET Y=$PIECE(APCHSN,U,6)
IF Y]""
SET APCHSDAT=$$FMTE^XLFDT(Y)
+18 IF APCHSDAT=""
SET Y=$PIECE(APCHSN,U,3)
SET Y=+^AUPNVSIT(Y,0)\1
SET APCHSDAT=$$FMTE^XLFDT(Y)
+19 SET APCHHOSA(APCHSIVD,"PRC",APCHSIEN)=APCHSDAT_U_APCHDES_U_APCHCODE
End DoDot:2
End DoDot:1
+20 ;now go through v cpt
+21 SET APCHT=$ORDER(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
+22 SET APCHCPTI=0
FOR
SET APCHCPTI=$ORDER(^AUPNVCPT("AA",APCHSDFN,APCHCPTI))
IF APCHCPTI'=+APCHCPTI
QUIT
Begin DoDot:1
+23 ;not a cpt wanted on this component
IF '$$ICD^ATXAPI(APCHCPTI,APCHT,1)
QUIT
+24 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVCPT("AA",APCHSDFN,APCHCPTI,APCHSIVD))
IF APCHSIVD=""
QUIT
Begin DoDot:2
+25 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^AUPNVCPT("AA",APCHSDFN,APCHCPTI,APCHSIVD,APCHSIEN))
IF APCHSIEN'=+APCHSIEN
QUIT
Begin DoDot:3
+26 SET Y=(9999999-APCHSIVD)
SET APCHSDAT=$$FMTE^XLFDT(Y)
+27 SET APCHSN=^AUPNVCPT(APCHSIEN,0)
+28 SET APCHSCNT=APCHSCNT+1
+29 ;cmi/anch/maw 8/28/2007 code set versioning
SET APCHDES=$PIECE($$CPT^ICPTCOD($PIECE(APCHSN,U,1),Y),U,3)
+30 SET APCHCODE=$PIECE($$CPT^ICPTCOD($PIECE(APCHSN,U,1),Y),U,2)
+31 SET APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=APCHSDAT_U_APCHDES_U_APCHCODE
+32 SET APCHHOSC(APCHSIVD,"CPT",$PIECE(^ICPT($PIECE(APCHSN,U,1),0),U,1))=""
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;now get all tran codes hcpcs
+34 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^AUPNVTC("AC",APCHSDFN,APCHSIEN))
IF APCHSIEN=""
QUIT
Begin DoDot:1
+35 IF '$DATA(^AUPNVTC(APCHSIEN))
QUIT
+36 SET V=$PIECE(^AUPNVTC(APCHSIEN,0),U,3)
+37 IF 'V
QUIT
+38 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+39 SET (APCHSDAT,V)=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+40 SET APCHSIVD=9999999-V
+41 SET APCHCPTI=$PIECE(^AUPNVTC(APCHSIEN,0),U,7)
+42 IF APCHCPTI=""
QUIT
+43 ;not a cpt wanted on this component
IF '$$ICD^ATXAPI(APCHCPTI,APCHT,1)
QUIT
+44 IF $DATA(APCHHOSC(APCHSIVD,"CPT",$PIECE(^ICPT(APCHCPTI,0),U,1)))
QUIT
+45 SET APCHDES=$PIECE($$CPT^ICPTCOD(APCHCPTI,APCHSDAT),U,3)
+46 SET APCHCODE=$PIECE($$CPT^ICPTCOD(APCHCPTI,APCHSDAT),U,2)
+47 SET APCHHOSA(APCHSIVD,"CPT",APCHSIEN)=$$FMTE^XLFDT(APCHSDAT)_U_APCHDES_U_APCHCODE
+48 SET APCHSCNT=APCHSCNT+1
End DoDot:1
+49 ;now display the procedures/cpt codes
+50 IF 'APCHSCNT
QUIT
+51 DO SUBHEAD^APCHPWHU
+52 DO S^APCHPWH1("PROCEDURES")
+53 DO WRITET^APCHPWHU("PROCEDURES")
+54 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHHOSA(APCHSIVD))
IF APCHSIVD=""
QUIT
Begin DoDot:1
+55 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(APCHHOSA(APCHSIVD,"PRC",APCHIEN))
IF APCHIEN'=+APCHIEN
QUIT
Begin DoDot:2
+56 SET APCHDES=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,2)
+57 SET APCHSDAT=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,1)
+58 SET APCHCODE=$PIECE(APCHHOSA(APCHSIVD,"PRC",APCHIEN),U,3)
+59 SET X=""
SET $EXTRACT(X,1)=APCHDES
SET $EXTRACT(X,60)=APCHSDAT
+60 DO S^APCHPWH1(X)
End DoDot:2
+61 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(APCHHOSA(APCHSIVD,"CPT",APCHIEN))
IF APCHIEN'=+APCHIEN!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+62 SET APCHDES=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,2)
+63 SET APCHSDAT=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,1)
+64 SET APCHCODE=$PIECE(APCHHOSA(APCHSIVD,"CPT",APCHIEN),U,3)
+65 SET X=""
SET $EXTRACT(X,1)=APCHDES
SET $EXTRACT(X,60)=APCHSDAT
+66 DO S^APCHPWH1(X)
End DoDot:2
End DoDot:1
HOSX ;
+1 KILL APCHHOSA,APCHHOSC
+2 QUIT
HOSCHK ;
+1 ;cmi/anch/maw CSV
SET APCHSCOD=$PIECE($$ICDOP^ICDEX(APCHSICD,,,"I"),U,2)
+2 IF $$ICD^ATXAPI(APCHSICD,$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
SET APCHSICD=""
+3 QUIT
