APCHS12 ; IHS/CMI/LAB - PART 12 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 8/28/2007 code set versioning in PVCH and FLOWCP
;
FLOW ; ********** FLOWSHEET PRODUCTION **********
; <SETUP>
Q:'$D(^AUPNVSIT("AA",APCHSPAT))
S APCHSFNM=0
S APCHSND2=APCHSNDM
F APCHSFOR=0:0 S APCHSFOR=$O(^APCHSCTL(APCHSTYP,6,APCHSFOR)) Q:'APCHSFOR S APCHSNDM=APCHSND2 D FLOWOUT Q:$D(APCHSQIT)
FLOWX K APCHSFOR,APCHSND2,APCHSDUS,APCHSFCN,APCHSIVD,APCHSTB,APCHSDB,APCHSI,APCHST,APCHSW,APCHSFDF,APCHSAS,APCHSVDF,APCHSN,APCHSIT,APCHSCLN
K APCHSDAT,APCHSIDF,APCHSITP,APCHSJ,APCHSL,APCHSMXL,APCHSTTL,APCHSVGL,APCHSX,APCHSXT,APCHSII,APCHSNGL,APCHSXS,APCHSFXF
K APCHSFOK,APCHSPI,APCHSCI,APCHSC1,APCHSC2,APCHSCM,APCHSFNM
Q
FLOWOUT ; <DISPLAY>
S APCHSFDF=$P(^APCHSCTL(APCHSTYP,6,APCHSFOR,0),U,2)
D FLOWCHK Q:'APCHSFOK
Q:'$$GENDER(APCHSFDF,APCHSPAT) ;not correct gender
Q:'$$AGE(APCHSFDF,APCHSPAT) ;not correct age
S APCHSFNM=APCHSFNM+1 I APCHSFNM=1 X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S APCHSFCN=$P(^APCHSFLC(APCHSFDF,0),U,1)
D FLOWTB
X APCHSCKP Q:$D(APCHSQIT) D FLOWHD
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D FLOWBD Q:$D(APCHSQIT) I APCHSDUS S APCHSNDM=APCHSNDM-1 Q:APCHSNDM=0
X APCHSCKP Q:$D(APCHSQIT) I 'APCHSNPG S APCHSP="",$P(APCHSP,"-",APCHSMXL+9)="" W ?2,APCHSP,!
X APCHSCKP Q:$D(APCHSQIT) I 'APCHSNPG W !
Q
FLOWCHK ; <SCREEN>
I '$O(^APCHSFLC(APCHSFDF,2,0)) S APCHSFOK=1 Q
S APCHSFOK=0
;Q:'$O(^AUPNPROB("AC",APCHSPAT,0))
F APCHSPI=0:0 S APCHSPI=$O(^AUPNPROB("AC",APCHSPAT,APCHSPI)) Q:'APCHSPI D FLOWCP Q:APCHSFOK
Q:APCHSFOK ;found on Problem list
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
K APCHY,APCHV,^TMP($J,"ALL VISITS")
S APCHSNVN=$S($P($G(^APCHSITE(DUZ(2),12,APCHSFDF,0)),U,2):$P($G(^APCHSITE(DUZ(2),12,APCHSFDF,0)),U,2),1:1)
S APCHSNYR=$S($P($G(^APCHSITE(DUZ(2),12,APCHSFDF,0)),U,3):$P($G(^APCHSITE(DUZ(2),12,APCHSFDF,0)),U,3),1:1)
S APCHSNYR=APCHSNYR*365
S APCHSBD=$$FMADD^XLFDT(DT,-(APCHSNYR))
S APCHY="^TMP($J,""ALL VISITS"",",%=APCHSPAT_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSBD)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,APCHY)
I '$D(^TMP($J,"ALL VISITS",1)) Q
S (X,APCHSCNT,APCHSFOK)=0 F S X=$O(^TMP($J,"ALL VISITS",X)) Q:X'=+X!(APCHSFOK) S V=$P(^TMP($J,"ALL VISITS",X),U,5) D
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"DAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:'$D(^AUPNVPOV("AD",V))
.;cmi/anch/maw 8/27/2007 mods for code set versioning
.;S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S APCHSCM=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCM S APCHSCM=$P($G(^ICD9(APCHSCM,0)),U) I APCHSCM]"" D CHKCODE
.N APCHSVDT
.S APCHSVDT=$P(+V,".")
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S APCHSCM=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCM S APCHSCM=$P($$ICDDX^ICDEX(APCHSCM,APCHSVDT),U,2) I APCHSCM]"" D CHKCODE
.;cmi/anch/maw 8/27/2007 end of mods
.Q:'D
.S Y=$$PRIMPROV^APCLV(V,"F")
.Q:'Y
.Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
.S APCHSCNT=APCHSCNT+1
.I APCHSCNT'<APCHSNVN S APCHSFOK=1
.Q
K ^TMP($J,"ALL VISITS"),APCHV,APCHY,APCHC
Q
FLOWCP ;
S APCHSP=^AUPNPROB(APCHSPI,0) Q:"ID"[$P(APCHSP,U,12) ;'="A"
;S APCHSCM=$P(^ICD9(+$P(APCHSP,U,1),0),U,1) cmi/anch/maw 8/27/2007 orig line
S APCHSCM=$$VAL^XBDIQ1(9000011,APCHSPI,.01) D CHKCODE I D S APCHSFOK=1
Q ;cmi/anch/maw 8/27/2007 code set versioning
F APCHSCI=0:0 S APCHSCI=$O(^APCHSFLC(APCHSFDF,2,APCHSCI)) Q:'APCHSCI D FLOWCR Q:APCHSFOK
Q
FLOWCR ;
S APCHSC1=$P(^APCHSFLC(APCHSFDF,2,APCHSCI,0),U,1)
I APCHSC1["-" S APCHSC2=$P(APCHSC1,"-",2),APCHSC1=$P(APCHSC1,"-",1)
E S APCHSC2=APCHSC1
S APCHSC1=APCHSC1_" ",APCHSC2=APCHSC2_" "
I APCHSC1'](APCHSCM_" "),(APCHSCM_" ")']APCHSC2 S APCHSFOK=1
;I APCHSC1']APCHSCM,APCHSCM']APCHSC2 S APCHSFOK=1
Q
CHKCODE ;
F APCHSCI=0:0 S APCHSCI=$O(^APCHSFLC(APCHSFDF,2,APCHSCI)) Q:'APCHSCI D CHKCODE1 Q:D
Q
CHKCODE1 ;
S D=0
S APCHSC1=$P(^APCHSFLC(APCHSFDF,2,APCHSCI,0),U,1)
I APCHSC1["-" S APCHSC2=$P(APCHSC1,"-",2),APCHSC1=$P(APCHSC1,"-",1)
E S APCHSC2=APCHSC1
;S APCHSC1=APCHSC1_" ",APCHSC2=APCHSC2_" "
;I APCHSC1'](APCHSCM_" "),(APCHSCM_" ")']APCHSC2 S D=1
S APCHCS=$P(^APCHSFLC(APCHSFDF,2,APCHSCI,0),U,2)
I APCHCS="" S APCHCS=1 ;if no coding system, assume icd-9
K APCHC
D LST^ATXAPI(APCHCS,80,APCHSC1_"-"_APCHSC2,"CODE","APCHC")
I $D(APCHC(APCHSCM_" ")) S D=1
K APCHC
Q
FLOWCKP ;ENTRY POINT
X APCHSCKP Q:$D(APCHSQIT) Q:'APCHSNPG
FLOWHD ;ENTRY POINT
; DISPLAY HEADER
X APCHSCKP Q:$D(APCHSQIT)
W APCHSFCN,!
I $O(^APCHSFLC(APCHSFDF,3,0)) W ?2,"Clinics limited to:" S X=0 F S X=$O(^APCHSFLC(APCHSFDF,3,X)) Q:'X X APCHSCKP Q:$D(APCHSQIT) G:APCHSNPG FLOWHD W ?22,$P(^DIC(40.7,X,0),U),!
X APCHSCKP Q:$D(APCHSQIT) G:APCHSNPG FLOWHD
F APCHSII=0:0 S APCHSII=$O(APCHSTB(APCHSII)) Q:'APCHSII W ?12+APCHSTB(APCHSII),APCHSTB(APCHSII,"L")
W !
Q
FLOWTB ; BUILD TAB TABLE
K APCHSTB
S APCHST=1,APCHSMXL=0
F APCHSI=0:0 S APCHSI=$O(^APCHSFLC(APCHSFDF,1,APCHSI)) Q:'APCHSI D FLOWTB2
Q
FLOWTB2 S APCHSW=0
Q:'($D(^APCHSFLC(APCHSFDF,1,APCHSI,0))#2) S APCHSN=^(0)
S APCHSTTL=$P(APCHSN,U,3) S APCHSP=$L(APCHSTTL) S:APCHSP>APCHSW APCHSW=APCHSP
S APCHSP=$P(APCHSN,U,4) S:+APCHSP>APCHSW APCHSW=APCHSP
S:APCHSW=0 APCHSW=10
S APCHSTB(APCHSI)=APCHST_"^"_APCHSW,APCHSTB(APCHSI,"L")=APCHSTTL
S APCHSMXL=APCHSMXL+APCHSW+2
S APCHST=APCHST+APCHSW+2
Q
FLOWBD ; BUILD AND DISPLAY DATA TABLE (FOR ONE DATE)
K APCHSDB
S APCHSDUS=0
F APCHSVDF=0:0 S APCHSVDF=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD,APCHSVDF)) Q:'APCHSVDF D FLOWB
D:$D(APCHSDB) FLOWD^APCHS12A
Q
FLOWB S APCHSCLN=$P(^AUPNVSIT(APCHSVDF,0),U,8)
I APCHSCLN,$O(^APCHSFLC(APCHSFDF,3,0)),'$D(^(APCHSCLN)) Q
S APCHSDUS=1
F APCHSIDF=0:0 S APCHSIDF=$O(^APCHSFLC(APCHSFDF,1,APCHSIDF)) Q:'APCHSIDF S APCHSJ=0 D FLOWB2 Q:$D(APCHSQIT)
Q
FLOWB2 S APCHSN=^APCHSFLC(APCHSFDF,1,APCHSIDF,0)
S APCHSIT=$P(APCHSN,U,2)
S APCHSFXF=$G(^APCHSFLC(APCHSFDF,1,APCHSIDF,1))
S APCHSX=^APCHSFLI(APCHSIT,1)
S APCHSXT=^APCHSFLI(APCHSIT,2)
S APCHSP=$P(^APCHSFLI(APCHSIT,0),U,3),APCHSVGL=^DIC(APCHSP,0,"GL")_"""AD"",APCHSVDF)"
S APCHSAS=$O(^APCHSFLC(APCHSFDF,1,APCHSIDF,2,0)),APCHSNGL=APCHSAS&'$O(^(APCHSAS)) D FLOWBA:'APCHSAS,FLOWBS:APCHSAS
Q
FLOWBS ; ADD SPECIFIED ITEMS
F DA=0:0 S DA=$O(@APCHSVGL@(DA)) Q:'DA D FLOWBS2
Q
FLOWBS2 ;
X APCHSXT
S APCHSITP=X
F I=0:0 S I=$O(^APCHSFLC(APCHSFDF,1,APCHSIDF,2,I)) Q:'I I +$P(^APCHSFLC(APCHSFDF,1,APCHSIDF,2,I,0),U,1)=APCHSITP D FLOWADD Q
Q
FLOWBA ; ADD ALL (NO ITEMS SPECIFIED)
F DA=0:0 S DA=$O(@APCHSVGL@(DA)) Q:'DA D FLOWADD
Q
FLOWADD ; ADD VALUE FROM SELECTED FILE/DFN
;QUIT IF MEASUREMENT IS DELETED
I APCHSVGL["AUPNVMSR" Q:$P($G(^AUPNVMSR(DA,2)),U,1)
S APCHSL=$P(APCHSTB(APCHSIDF),U,2)
X APCHSX
FLOWS I $L(X),$E(X,$L(X))=" " S X=$E(X,1,$L(X)-1) G FLOWS
I APCHSFXF]"",$P(X,"=",2)]"" S APCHSXS=$P(X,"="),X=$P(X,"=",2) X APCHSFXF S X=APCHSXS_"="_X
;S:$E(X,$L(X))="=" X=$P(X,"=")_"n/r"
S:$E(X,$L(X))="=" X="n/r" ;per Gary Lawless do not display name of test 12/26/01
I $G(^APCHSFLC(APCHSFDF,1,APCHSIDF,3))]"" X ^APCHSFLC(APCHSFDF,1,APCHSIDF,3)
;I $G(^APCHSFLC(APCHSFDF,1,APCHSIDF,1))]"" X ^APCHSFLC(APCHSFDF,1,APCHSIDF,1) ;IHS/CMI/GRL execute flowsheet order transform code
I APCHSNGL,X["=" S X=$P(X,"=",2)
I $$VAL^XBDIQ1(9001019,APCHSIT,.01)="LAB RESULT",X["=",$P(X,"=",2)[" " S X=$P($P(X,"=",2)," ") ;CMI/GRL remove alpha comment after lab result
F APCHSI=1:APCHSL S APCHSP=$E(X,APCHSI,APCHSL+APCHSI-1) Q:APCHSP="" S APCHSJ=APCHSJ+1,APCHSDB(APCHSJ,APCHSIDF)=APCHSP
Q
GENDER(I,P) ;
I $P(^APCHSFLC(I,0),U,2)="" Q 1
I $P(^DPT(P,0),U,2)'=$P(^APCHSFLC(I,0),U,2) Q 0
Q 1
AGE(I,P) ;
NEW A,B,C
S A=$P(^APCHSFLC(I,0),U,3) ;lower age
S B=$P(^APCHSFLC(I,0),U,4) ;upper age
I A="",B="" Q 1
S C=$$AGE^AUPNPAT(P,DT)
I A]"",C<A Q 0
I B]"",C>B Q 0
Q 1
APCHS12 ; IHS/CMI/LAB - PART 12 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 8/28/2007 code set versioning in PVCH and FLOWCP
+4 ;
FLOW ; ********** FLOWSHEET PRODUCTION **********
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVSIT("AA",APCHSPAT))
QUIT
+3 SET APCHSFNM=0
+4 SET APCHSND2=APCHSNDM
+5 FOR APCHSFOR=0:0
SET APCHSFOR=$ORDER(^APCHSCTL(APCHSTYP,6,APCHSFOR))
IF 'APCHSFOR
QUIT
SET APCHSNDM=APCHSND2
DO FLOWOUT
IF $DATA(APCHSQIT)
QUIT
FLOWX KILL APCHSFOR,APCHSND2,APCHSDUS,APCHSFCN,APCHSIVD,APCHSTB,APCHSDB,APCHSI,APCHST,APCHSW,APCHSFDF,APCHSAS,APCHSVDF,APCHSN,APCHSIT,APCHSCLN
+1 KILL APCHSDAT,APCHSIDF,APCHSITP,APCHSJ,APCHSL,APCHSMXL,APCHSTTL,APCHSVGL,APCHSX,APCHSXT,APCHSII,APCHSNGL,APCHSXS,APCHSFXF
+2 KILL APCHSFOK,APCHSPI,APCHSCI,APCHSC1,APCHSC2,APCHSCM,APCHSFNM
+3 QUIT
FLOWOUT ; <DISPLAY>
+1 SET APCHSFDF=$PIECE(^APCHSCTL(APCHSTYP,6,APCHSFOR,0),U,2)
+2 DO FLOWCHK
IF 'APCHSFOK
QUIT
+3 ;not correct gender
IF '$$GENDER(APCHSFDF,APCHSPAT)
QUIT
+4 ;not correct age
IF '$$AGE(APCHSFDF,APCHSPAT)
QUIT
+5 SET APCHSFNM=APCHSFNM+1
IF APCHSFNM=1
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 SET APCHSFCN=$PIECE(^APCHSFLC(APCHSFDF,0),U,1)
+7 DO FLOWTB
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
DO FLOWHD
+9 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVSIT("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
DO FLOWBD
IF $DATA(APCHSQIT)
QUIT
IF APCHSDUS
SET APCHSNDM=APCHSNDM-1
IF APCHSNDM=0
QUIT
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
SET APCHSP=""
SET $PIECE(APCHSP,"-",APCHSMXL+9)=""
WRITE ?2,APCHSP,!
+11 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
WRITE !
+12 QUIT
FLOWCHK ; <SCREEN>
+1 IF '$ORDER(^APCHSFLC(APCHSFDF,2,0))
SET APCHSFOK=1
QUIT
+2 SET APCHSFOK=0
+3 ;Q:'$O(^AUPNPROB("AC",APCHSPAT,0))
+4 FOR APCHSPI=0:0
SET APCHSPI=$ORDER(^AUPNPROB("AC",APCHSPAT,APCHSPI))
IF 'APCHSPI
QUIT
DO FLOWCP
IF APCHSFOK
QUIT
+5 ;found on Problem list
IF APCHSFOK
QUIT
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
+1 KILL APCHY,APCHV,^TMP($JOB,"ALL VISITS")
+2 SET APCHSNVN=$SELECT($PIECE($GET(^APCHSITE(DUZ(2),12,APCHSFDF,0)),U,2):$PIECE($GET(^APCHSITE(DUZ(2),12,APCHSFDF,0)),U,2),1:1)
+3 SET APCHSNYR=$SELECT($PIECE($GET(^APCHSITE(DUZ(2),12,APCHSFDF,0)),U,3):$PIECE($GET(^APCHSITE(DUZ(2),12,APCHSFDF,0)),U,3),1:1)
+4 SET APCHSNYR=APCHSNYR*365
+5 SET APCHSBD=$$FMADD^XLFDT(DT,-(APCHSNYR))
+6 SET APCHY="^TMP($J,""ALL VISITS"","
SET %=APCHSPAT_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSBD)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,APCHY)
+7 IF '$DATA(^TMP($JOB,"ALL VISITS",1))
QUIT
+8 SET (X,APCHSCNT,APCHSFOK)=0
FOR
SET X=$ORDER(^TMP($JOB,"ALL VISITS",X))
IF X'=+X!(APCHSFOK)
QUIT
SET V=$PIECE(^TMP($JOB,"ALL VISITS",X),U,5)
Begin DoDot:1
+9 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+10 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+11 IF "DAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+12 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+13 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+14 ;cmi/anch/maw 8/27/2007 mods for code set versioning
+15 ;S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S APCHSCM=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCM S APCHSCM=$P($G(^ICD9(APCHSCM,0)),U) I APCHSCM]"" D CHKCODE
+16 NEW APCHSVDT
+17 SET APCHSVDT=$PIECE(+V,".")
+18 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
SET APCHSCM=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF APCHSCM
SET APCHSCM=$PIECE($$ICDDX^ICDEX(APCHSCM,APCHSVDT),U,2)
IF APCHSCM]""
DO CHKCODE
+19 ;cmi/anch/maw 8/27/2007 end of mods
+20 IF 'D
QUIT
+21 SET Y=$$PRIMPROV^APCLV(V,"F")
+22 IF 'Y
QUIT
+23 IF $PIECE($GET(^DIC(7,Y,9999999)),U,3)'="Y"
QUIT
+24 SET APCHSCNT=APCHSCNT+1
+25 IF APCHSCNT'<APCHSNVN
SET APCHSFOK=1
+26 QUIT
End DoDot:1
+27 KILL ^TMP($JOB,"ALL VISITS"),APCHV,APCHY,APCHC
+28 QUIT
FLOWCP ;
+1 ;'="A"
SET APCHSP=^AUPNPROB(APCHSPI,0)
IF "ID"[$PIECE(APCHSP,U,12)
QUIT
+2 ;S APCHSCM=$P(^ICD9(+$P(APCHSP,U,1),0),U,1) cmi/anch/maw 8/27/2007 orig line
+3 SET APCHSCM=$$VAL^XBDIQ1(9000011,APCHSPI,.01)
DO CHKCODE
IF D
SET APCHSFOK=1
+4 ;cmi/anch/maw 8/27/2007 code set versioning
QUIT
+5 FOR APCHSCI=0:0
SET APCHSCI=$ORDER(^APCHSFLC(APCHSFDF,2,APCHSCI))
IF 'APCHSCI
QUIT
DO FLOWCR
IF APCHSFOK
QUIT
+6 QUIT
FLOWCR ;
+1 SET APCHSC1=$PIECE(^APCHSFLC(APCHSFDF,2,APCHSCI,0),U,1)
+2 IF APCHSC1["-"
SET APCHSC2=$PIECE(APCHSC1,"-",2)
SET APCHSC1=$PIECE(APCHSC1,"-",1)
+3 IF '$TEST
SET APCHSC2=APCHSC1
+4 SET APCHSC1=APCHSC1_" "
SET APCHSC2=APCHSC2_" "
+5 IF APCHSC1'](APCHSCM_" ")
IF (APCHSCM_" ")']APCHSC2
SET APCHSFOK=1
+6 ;I APCHSC1']APCHSCM,APCHSCM']APCHSC2 S APCHSFOK=1
+7 QUIT
CHKCODE ;
+1 FOR APCHSCI=0:0
SET APCHSCI=$ORDER(^APCHSFLC(APCHSFDF,2,APCHSCI))
IF 'APCHSCI
QUIT
DO CHKCODE1
IF D
QUIT
+2 QUIT
CHKCODE1 ;
+1 SET D=0
+2 SET APCHSC1=$PIECE(^APCHSFLC(APCHSFDF,2,APCHSCI,0),U,1)
+3 IF APCHSC1["-"
SET APCHSC2=$PIECE(APCHSC1,"-",2)
SET APCHSC1=$PIECE(APCHSC1,"-",1)
+4 IF '$TEST
SET APCHSC2=APCHSC1
+5 ;S APCHSC1=APCHSC1_" ",APCHSC2=APCHSC2_" "
+6 ;I APCHSC1'](APCHSCM_" "),(APCHSCM_" ")']APCHSC2 S D=1
+7 SET APCHCS=$PIECE(^APCHSFLC(APCHSFDF,2,APCHSCI,0),U,2)
+8 ;if no coding system, assume icd-9
IF APCHCS=""
SET APCHCS=1
+9 KILL APCHC
+10 DO LST^ATXAPI(APCHCS,80,APCHSC1_"-"_APCHSC2,"CODE","APCHC")
+11 IF $DATA(APCHC(APCHSCM_" "))
SET D=1
+12 KILL APCHC
+13 QUIT
FLOWCKP ;ENTRY POINT
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
QUIT
FLOWHD ;ENTRY POINT
+1 ; DISPLAY HEADER
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 WRITE APCHSFCN,!
+4 IF $ORDER(^APCHSFLC(APCHSFDF,3,0))
WRITE ?2,"Clinics limited to:"
SET X=0
FOR
SET X=$ORDER(^APCHSFLC(APCHSFDF,3,X))
IF 'X
QUIT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
GOTO FLOWHD
WRITE ?22,$PIECE(^DIC(40.7,X,0),U),!
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
GOTO FLOWHD
+6 FOR APCHSII=0:0
SET APCHSII=$ORDER(APCHSTB(APCHSII))
IF 'APCHSII
QUIT
WRITE ?12+APCHSTB(APCHSII),APCHSTB(APCHSII,"L")
+7 WRITE !
+8 QUIT
FLOWTB ; BUILD TAB TABLE
+1 KILL APCHSTB
+2 SET APCHST=1
SET APCHSMXL=0
+3 FOR APCHSI=0:0
SET APCHSI=$ORDER(^APCHSFLC(APCHSFDF,1,APCHSI))
IF 'APCHSI
QUIT
DO FLOWTB2
+4 QUIT
FLOWTB2 SET APCHSW=0
+1 IF '($DATA(^APCHSFLC(APCHSFDF,1,APCHSI,0))#2)
QUIT
SET APCHSN=^(0)
+2 SET APCHSTTL=$PIECE(APCHSN,U,3)
SET APCHSP=$LENGTH(APCHSTTL)
IF APCHSP>APCHSW
SET APCHSW=APCHSP
+3 SET APCHSP=$PIECE(APCHSN,U,4)
IF +APCHSP>APCHSW
SET APCHSW=APCHSP
+4 IF APCHSW=0
SET APCHSW=10
+5 SET APCHSTB(APCHSI)=APCHST_"^"_APCHSW
SET APCHSTB(APCHSI,"L")=APCHSTTL
+6 SET APCHSMXL=APCHSMXL+APCHSW+2
+7 SET APCHST=APCHST+APCHSW+2
+8 QUIT
FLOWBD ; BUILD AND DISPLAY DATA TABLE (FOR ONE DATE)
+1 KILL APCHSDB
+2 SET APCHSDUS=0
+3 FOR APCHSVDF=0:0
SET APCHSVDF=$ORDER(^AUPNVSIT("AA",APCHSPAT,APCHSIVD,APCHSVDF))
IF 'APCHSVDF
QUIT
DO FLOWB
+4 IF $DATA(APCHSDB)
DO FLOWD^APCHS12A
+5 QUIT
FLOWB SET APCHSCLN=$PIECE(^AUPNVSIT(APCHSVDF,0),U,8)
+1 IF APCHSCLN
IF $ORDER(^APCHSFLC(APCHSFDF,3,0))
IF '$DATA(^(APCHSCLN))
QUIT
+2 SET APCHSDUS=1
+3 FOR APCHSIDF=0:0
SET APCHSIDF=$ORDER(^APCHSFLC(APCHSFDF,1,APCHSIDF))
IF 'APCHSIDF
QUIT
SET APCHSJ=0
DO FLOWB2
IF $DATA(APCHSQIT)
QUIT
+4 QUIT
FLOWB2 SET APCHSN=^APCHSFLC(APCHSFDF,1,APCHSIDF,0)
+1 SET APCHSIT=$PIECE(APCHSN,U,2)
+2 SET APCHSFXF=$GET(^APCHSFLC(APCHSFDF,1,APCHSIDF,1))
+3 SET APCHSX=^APCHSFLI(APCHSIT,1)
+4 SET APCHSXT=^APCHSFLI(APCHSIT,2)
+5 SET APCHSP=$PIECE(^APCHSFLI(APCHSIT,0),U,3)
SET APCHSVGL=^DIC(APCHSP,0,"GL")_"""AD"",APCHSVDF)"
+6 SET APCHSAS=$ORDER(^APCHSFLC(APCHSFDF,1,APCHSIDF,2,0))
SET APCHSNGL=APCHSAS&'$ORDER(^(APCHSAS))
IF 'APCHSAS
DO FLOWBA
IF APCHSAS
DO FLOWBS
+7 QUIT
FLOWBS ; ADD SPECIFIED ITEMS
+1 FOR DA=0:0
SET DA=$ORDER(@APCHSVGL@(DA))
IF 'DA
QUIT
DO FLOWBS2
+2 QUIT
FLOWBS2 ;
+1 XECUTE APCHSXT
+2 SET APCHSITP=X
+3 FOR I=0:0
SET I=$ORDER(^APCHSFLC(APCHSFDF,1,APCHSIDF,2,I))
IF 'I
QUIT
IF +$PIECE(^APCHSFLC(APCHSFDF,1,APCHSIDF,2,I,0),U,1)=APCHSITP
DO FLOWADD
QUIT
+4 QUIT
FLOWBA ; ADD ALL (NO ITEMS SPECIFIED)
+1 FOR DA=0:0
SET DA=$ORDER(@APCHSVGL@(DA))
IF 'DA
QUIT
DO FLOWADD
+2 QUIT
FLOWADD ; ADD VALUE FROM SELECTED FILE/DFN
+1 ;QUIT IF MEASUREMENT IS DELETED
+2 IF APCHSVGL["AUPNVMSR"
IF $PIECE($GET(^AUPNVMSR(DA,2)),U,1)
QUIT
+3 SET APCHSL=$PIECE(APCHSTB(APCHSIDF),U,2)
+4 XECUTE APCHSX
FLOWS IF $LENGTH(X)
IF $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
GOTO FLOWS
+1 IF APCHSFXF]""
IF $PIECE(X,"=",2)]""
SET APCHSXS=$PIECE(X,"=")
SET X=$PIECE(X,"=",2)
XECUTE APCHSFXF
SET X=APCHSXS_"="_X
+2 ;S:$E(X,$L(X))="=" X=$P(X,"=")_"n/r"
+3 ;per Gary Lawless do not display name of test 12/26/01
IF $EXTRACT(X,$LENGTH(X))="="
SET X="n/r"
+4 IF $GET(^APCHSFLC(APCHSFDF,1,APCHSIDF,3))]""
XECUTE ^APCHSFLC(APCHSFDF,1,APCHSIDF,3)
+5 ;I $G(^APCHSFLC(APCHSFDF,1,APCHSIDF,1))]"" X ^APCHSFLC(APCHSFDF,1,APCHSIDF,1) ;IHS/CMI/GRL execute flowsheet order transform code
+6 IF APCHSNGL
IF X["="
SET X=$PIECE(X,"=",2)
+7 ;CMI/GRL remove alpha comment after lab result
IF $$VAL^XBDIQ1(9001019,APCHSIT,.01)="LAB RESULT"
IF X["="
IF $PIECE(X,"=",2)[" "
SET X=$PIECE($PIECE(X,"=",2)," ")
+8 FOR APCHSI=1:APCHSL
SET APCHSP=$EXTRACT(X,APCHSI,APCHSL+APCHSI-1)
IF APCHSP=""
QUIT
SET APCHSJ=APCHSJ+1
SET APCHSDB(APCHSJ,APCHSIDF)=APCHSP
+9 QUIT
GENDER(I,P) ;
+1 IF $PIECE(^APCHSFLC(I,0),U,2)=""
QUIT 1
+2 IF $PIECE(^DPT(P,0),U,2)'=$PIECE(^APCHSFLC(I,0),U,2)
QUIT 0
+3 QUIT 1
AGE(I,P) ;
+1 NEW A,B,C
+2 ;lower age
SET A=$PIECE(^APCHSFLC(I,0),U,3)
+3 ;upper age
SET B=$PIECE(^APCHSFLC(I,0),U,4)
+4 IF A=""
IF B=""
QUIT 1
+5 SET C=$$AGE^AUPNPAT(P,DT)
+6 IF A]""
IF C<A
QUIT 0
+7 IF B]""
IF C>B
QUIT 0
+8 QUIT 1
