APCHS12.m

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