APCHS6B ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**4,10**;MAY 14, 2009;Build 88
;
WCE ; ******************** WELL CHILD EXAM * 9000010 *******
N LINE,ARR
; <SETUP>
; I '$D(^AUPNVWC("AC",APCHSPAT)) Q
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
D WCESEG(APCHSPAT) ; CREATE THE DISPLAY ARRAY
D PRINT ; PRINT THE SEGMENT
; <CLEANUP>
CLEANUP K APCHSDFN,APCHSN,APCHSICD,APCHSDAT,APCHSNRQ,APCHSICL
Q
;
LINE(STG) ; EP-CREATE A LINE IN THE SEGMENT
S LINE=LINE+1
S LINE(LINE)=STG
Q
;
PRINT ; EP-PRINT RESULTS
N CNT
S CNT=0
F S CNT=$O(LINE(CNT)) Q:'CNT D I $D(APCHSQIT) Q
. W !
. X APCHSCKP Q:$D(APCHSQIT)
. S X=LINE(CNT)
. W X
. Q
Q
;
WCESEG(DFN) ; PRINT ALL WELL CHILD REMINDERS AND LAST RESULTS
N STG,SEX,AM,DAGE,MOM,X,SEGIEN,DAYS
S LINE=0
S STG=$G(^DPT(+$G(DFN),0)) I '$L(STG) Q ; INVALID DFN
S SEX=$S($P(STG,U,2)="M":"Male",$P(STG,U,2)="F":"Female",$P(STG,U,2)="U":"UNKNOWN",1:"") ; SEX
S MOM=$P($G(^DPT(DFN,.24)),U,2)
I MOM="" S MOM=$P($G(^DPT(DFN,.24)),U,3)
I MOM="" S MOM="??"
S AM=$$AM(DFN,.DAYS)
I 'AM Q ; AGE IN MONTHS
I 'DAYS S DAYS=1
S DAGE=$$DAGE(AM) I '$L(DAGE) Q ; DISPLAY AGE
S X=SEX_" "_DAGE_" Mother: "_MOM D LINE(X) ; INTRO DATA LINE
I '$L($G(APCHSEGH)) Q ; SEGMENT NAME MUST EXIST
S SEGIEN=$O(^APCHSCMP("B",$G(APCHSEGH),0)) I 'SEGIEN Q ; SEMENT IEN
D REM(DFN,SEGIEN,SEX,DAYS) ; GET REMINDERS FOR EA KB CATEGORY
D LINE(" ")
Q
;
REM(DFN,SEGIEN,SEX,DAYS) ; REMINDERS
N CATIEN,KBIEN,CAT,K,HDR,AGE,ARR,X,CNT,TOT,STG,ORD,CIEN,KTYPE,KIEN,MOD,PEIEN
N START,STOP,TITLE,TOT,DOM,ORD,DNAME,DORD,D
S AGE=$G(DAYS) I 'AGE Q
S SEX=$E(SEX) ; SCREEN BY SEX
S DOM=0
F S DOM=$O(^VEN(7.13,DOM)) Q:'DOM D
. S %=$G(^VEN(7.13,DOM,0)) I '$L(%) Q
. I '$P(%,U,7) Q ; SKIP INACTIVE DOMAINE
. S DNAME=$P(%,U)
. S DORD=$P(%,U,5)
. I 'DORD S DORD=100+(DOM*5)
. S CAT=0
. F S CAT=$O(^VEN(7.13,DOM,1,CAT)) Q:'CAT D ; CREATE THE ORDINAL ARRAY
.. S %=$G(^VEN(7.13,DOM,1,CAT,0))
.. S CATIEN=+% I 'CATIEN Q
.. S ORD=$P(%,U,2)
.. I 'ORD S ORD=100+CAT ; MAKE SURE EVERY CAT HAS AN ORDER - EVEN IF ONE IS NOT OFFICIALLY ASSIGNED
.. S ORD(DORD,ORD)=CATIEN
.. Q
. Q
S DORD=0
F S DORD=$O(ORD(DORD)) Q:'DORD D
. S ORD=0
. F S ORD=$O(ORD(DORD,ORD)) Q:'ORD S CATIEN=ORD(DORD,ORD) D KBI(CATIEN)
. Q
Q
;
KBI(CATIEN) ; GET KB ITEMS
N LASTLINE,ARR
S K=$G(^VEN(7.11,CATIEN,0)) I '$L(K) Q
S HDR=$P(K,U,9) ; CATEGORY HEADER
S KTYPE=$P(K,U,11) ; TYPE OF KB ITEM: PT ED, DEVEL, SCREENING, ETC.
D LINE(" "),LINE(HDR) ; SET THE SPACER AND HEADER LINES FOR THIS CATEGORY OF ITEMS
S LASTLINE=LINE
S KIEN=0,TOT=0 K ARR
F S KIEN=$O(^VEN(7.12,"B",CATIEN,KIEN)) Q:'KIEN D ; CHECK EA. ENTRY IN THE KNOWLEDGE CATEGORY
. S STG=$G(^VEN(7.12,KIEN,0)) I '$L(STG) Q
. I $P(STG,U,11) Q ; INACTIVE ITEM
. S START=$P(STG,U,5) I AGE<START Q
. S STOP=$P(STG,U,6) I AGE>STOP Q
. S %=$P(STG,U,10) I $L(%),%'=SEX Q
. S TITLE=$P(STG,U,2) I '$L(TITLE) Q
. S MOD=$P(STG,U,12)
. I $L(MOD) S TITLE=TITLE_" ("_MOD_")"
. I MOD,KTYPE=2 S ARR(MOD)="__ "_TITLE Q ; STORE DEV ITEM LINES IN TEMP ARRAY FOR SORTING AND QUIT HERE
. ; PROCEED IF SECONDARY SORTING IS NOT REQUIRED
. S TOT(CATIEN)=$G(TOT(CATIEN))+1
. I $L($T(LAST^VENPCCK)) D LAST^VENPCCK(CATIEN,KIEN,DFN,.TITLE)
. S X="__ "_TOT(CATIEN)_". "_TITLE
. I $G(SEGIEN)=-1 S X=X_"|"_KIEN ; HIJACKED PROCESS SO APPEND ITEM IEN
. D LINE(X) ; SET THE ITEM NODE
. Q
I $D(ARR) D ; SORT BY %ILE
. S MOD=999
. F S MOD=$O(ARR(MOD),-1) Q:MOD="" S X=ARR(MOD) D LINE(X)
. K ARR
. Q
NOITEMS I LINE'=LASTLINE Q
S LINE=LINE-2
K LINE(LINE+1),LINE(LINE+2) ; NOTHING FOUND UNDER THIS KB CATEGORY SO REMOVER CAT HEADER
Q
;
AM(DFN,DAYS) ; EP - GIVEN A DFN, RETURN THE PTS CURRENT AGE IN MONTHS
N DOB,DIFF,MD,YD,DD,M
S DOB=$P($G(^DPT(DFN,0)),U,3) I 'DOB Q ""
I DOB>DT Q "" ; INVALID DOB
S (DAYS,D)=$$FMDIFF^XLFDT(DT,DOB,1)
I D<8 Q 0
I D<15 Q .25
I D<22 Q .5
I D<29 Q .75
S YD=$E(DT,1,3)-$E(DOB,1,3)
S MD=$E(DT,4,5)-$E(DOB,4,5)
S DD=$E(DT,6,7)-$E(DOB,6,7)
I DD<0 S MD=MD-1
I MD<1 S MD=MD+12,YD=YD-1
S M=MD+(YD*12)
I M<2 Q 1
Q M
;
DAGE(AM) ; EP - GIVEN AN AGE IN MONTHS, RETURN THE DISPLAY AGE
N DAGE,M
;I AM<1 Q $$FMDIFF^XLFDT(DT,DOB,1)_" days old"
I AM<1 Q $$FMDIFF^XLFDT(DT,$P(^DPT(DFN,0),U,3),1)_" days old"
S M=(AM#12)
I AM>35 Q (AM\12)_" years and "_M_" month"_$S(M=1:"",1:"s")
Q AM_" month"_$S(AM=1:"",1:"s")
Q DAGE
;
APCHS6B ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**4,10**;MAY 14, 2009;Build 88
+2 ;
WCE ; ******************** WELL CHILD EXAM * 9000010 *******
+1 NEW LINE,ARR
+2 ; <SETUP>
+3 ; I '$D(^AUPNVWC("AC",APCHSPAT)) Q
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+5 ; <DISPLAY>
+6 ; CREATE THE DISPLAY ARRAY
DO WCESEG(APCHSPAT)
+7 ; PRINT THE SEGMENT
DO PRINT
+8 ; <CLEANUP>
CLEANUP KILL APCHSDFN,APCHSN,APCHSICD,APCHSDAT,APCHSNRQ,APCHSICL
+1 QUIT
+2 ;
LINE(STG) ; EP-CREATE A LINE IN THE SEGMENT
+1 SET LINE=LINE+1
+2 SET LINE(LINE)=STG
+3 QUIT
+4 ;
PRINT ; EP-PRINT RESULTS
+1 NEW CNT
+2 SET CNT=0
+3 FOR
SET CNT=$ORDER(LINE(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+4 WRITE !
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 SET X=LINE(CNT)
+7 WRITE X
+8 QUIT
End DoDot:1
IF $DATA(APCHSQIT)
QUIT
+9 QUIT
+10 ;
WCESEG(DFN) ; PRINT ALL WELL CHILD REMINDERS AND LAST RESULTS
+1 NEW STG,SEX,AM,DAGE,MOM,X,SEGIEN,DAYS
+2 SET LINE=0
+3 ; INVALID DFN
SET STG=$GET(^DPT(+$GET(DFN),0))
IF '$LENGTH(STG)
QUIT
+4 ; SEX
SET SEX=$SELECT($PIECE(STG,U,2)="M":"Male",$PIECE(STG,U,2)="F":"Female",$PIECE(STG,U,2)="U":"UNKNOWN",1:"")
+5 SET MOM=$PIECE($GET(^DPT(DFN,.24)),U,2)
+6 IF MOM=""
SET MOM=$PIECE($GET(^DPT(DFN,.24)),U,3)
+7 IF MOM=""
SET MOM="??"
+8 SET AM=$$AM(DFN,.DAYS)
+9 ; AGE IN MONTHS
IF 'AM
QUIT
+10 IF 'DAYS
SET DAYS=1
+11 ; DISPLAY AGE
SET DAGE=$$DAGE(AM)
IF '$LENGTH(DAGE)
QUIT
+12 ; INTRO DATA LINE
SET X=SEX_" "_DAGE_" Mother: "_MOM
DO LINE(X)
+13 ; SEGMENT NAME MUST EXIST
IF '$LENGTH($GET(APCHSEGH))
QUIT
+14 ; SEMENT IEN
SET SEGIEN=$ORDER(^APCHSCMP("B",$GET(APCHSEGH),0))
IF 'SEGIEN
QUIT
+15 ; GET REMINDERS FOR EA KB CATEGORY
DO REM(DFN,SEGIEN,SEX,DAYS)
+16 DO LINE(" ")
+17 QUIT
+18 ;
REM(DFN,SEGIEN,SEX,DAYS) ; REMINDERS
+1 NEW CATIEN,KBIEN,CAT,K,HDR,AGE,ARR,X,CNT,TOT,STG,ORD,CIEN,KTYPE,KIEN,MOD,PEIEN
+2 NEW START,STOP,TITLE,TOT,DOM,ORD,DNAME,DORD,D
+3 SET AGE=$GET(DAYS)
IF 'AGE
QUIT
+4 ; SCREEN BY SEX
SET SEX=$EXTRACT(SEX)
+5 SET DOM=0
+6 FOR
SET DOM=$ORDER(^VEN(7.13,DOM))
IF 'DOM
QUIT
Begin DoDot:1
+7 SET %=$GET(^VEN(7.13,DOM,0))
IF '$LENGTH(%)
QUIT
+8 ; SKIP INACTIVE DOMAINE
IF '$PIECE(%,U,7)
QUIT
+9 SET DNAME=$PIECE(%,U)
+10 SET DORD=$PIECE(%,U,5)
+11 IF 'DORD
SET DORD=100+(DOM*5)
+12 SET CAT=0
+13 ; CREATE THE ORDINAL ARRAY
FOR
SET CAT=$ORDER(^VEN(7.13,DOM,1,CAT))
IF 'CAT
QUIT
Begin DoDot:2
+14 SET %=$GET(^VEN(7.13,DOM,1,CAT,0))
+15 SET CATIEN=+%
IF 'CATIEN
QUIT
+16 SET ORD=$PIECE(%,U,2)
+17 ; MAKE SURE EVERY CAT HAS AN ORDER - EVEN IF ONE IS NOT OFFICIALLY ASSIGNED
IF 'ORD
SET ORD=100+CAT
+18 SET ORD(DORD,ORD)=CATIEN
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 SET DORD=0
+22 FOR
SET DORD=$ORDER(ORD(DORD))
IF 'DORD
QUIT
Begin DoDot:1
+23 SET ORD=0
+24 FOR
SET ORD=$ORDER(ORD(DORD,ORD))
IF 'ORD
QUIT
SET CATIEN=ORD(DORD,ORD)
DO KBI(CATIEN)
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
KBI(CATIEN) ; GET KB ITEMS
+1 NEW LASTLINE,ARR
+2 SET K=$GET(^VEN(7.11,CATIEN,0))
IF '$LENGTH(K)
QUIT
+3 ; CATEGORY HEADER
SET HDR=$PIECE(K,U,9)
+4 ; TYPE OF KB ITEM: PT ED, DEVEL, SCREENING, ETC.
SET KTYPE=$PIECE(K,U,11)
+5 ; SET THE SPACER AND HEADER LINES FOR THIS CATEGORY OF ITEMS
DO LINE(" ")
DO LINE(HDR)
+6 SET LASTLINE=LINE
+7 SET KIEN=0
SET TOT=0
KILL ARR
+8 ; CHECK EA. ENTRY IN THE KNOWLEDGE CATEGORY
FOR
SET KIEN=$ORDER(^VEN(7.12,"B",CATIEN,KIEN))
IF 'KIEN
QUIT
Begin DoDot:1
+9 SET STG=$GET(^VEN(7.12,KIEN,0))
IF '$LENGTH(STG)
QUIT
+10 ; INACTIVE ITEM
IF $PIECE(STG,U,11)
QUIT
+11 SET START=$PIECE(STG,U,5)
IF AGE<START
QUIT
+12 SET STOP=$PIECE(STG,U,6)
IF AGE>STOP
QUIT
+13 SET %=$PIECE(STG,U,10)
IF $LENGTH(%)
IF %'=SEX
QUIT
+14 SET TITLE=$PIECE(STG,U,2)
IF '$LENGTH(TITLE)
QUIT
+15 SET MOD=$PIECE(STG,U,12)
+16 IF $LENGTH(MOD)
SET TITLE=TITLE_" ("_MOD_")"
+17 ; STORE DEV ITEM LINES IN TEMP ARRAY FOR SORTING AND QUIT HERE
IF MOD
IF KTYPE=2
SET ARR(MOD)="__ "_TITLE
QUIT
+18 ; PROCEED IF SECONDARY SORTING IS NOT REQUIRED
+19 SET TOT(CATIEN)=$GET(TOT(CATIEN))+1
+20 IF $LENGTH($TEXT(LAST^VENPCCK))
DO LAST^VENPCCK(CATIEN,KIEN,DFN,.TITLE)
+21 SET X="__ "_TOT(CATIEN)_". "_TITLE
+22 ; HIJACKED PROCESS SO APPEND ITEM IEN
IF $GET(SEGIEN)=-1
SET X=X_"|"_KIEN
+23 ; SET THE ITEM NODE
DO LINE(X)
+24 QUIT
End DoDot:1
+25 ; SORT BY %ILE
IF $DATA(ARR)
Begin DoDot:1
+26 SET MOD=999
+27 FOR
SET MOD=$ORDER(ARR(MOD),-1)
IF MOD=""
QUIT
SET X=ARR(MOD)
DO LINE(X)
+28 KILL ARR
+29 QUIT
End DoDot:1
NOITEMS IF LINE'=LASTLINE
QUIT
+1 SET LINE=LINE-2
+2 ; NOTHING FOUND UNDER THIS KB CATEGORY SO REMOVER CAT HEADER
KILL LINE(LINE+1),LINE(LINE+2)
+3 QUIT
+4 ;
AM(DFN,DAYS) ; EP - GIVEN A DFN, RETURN THE PTS CURRENT AGE IN MONTHS
+1 NEW DOB,DIFF,MD,YD,DD,M
+2 SET DOB=$PIECE($GET(^DPT(DFN,0)),U,3)
IF 'DOB
QUIT ""
+3 ; INVALID DOB
IF DOB>DT
QUIT ""
+4 SET (DAYS,D)=$$FMDIFF^XLFDT(DT,DOB,1)
+5 IF D<8
QUIT 0
+6 IF D<15
QUIT .25
+7 IF D<22
QUIT .5
+8 IF D<29
QUIT .75
+9 SET YD=$EXTRACT(DT,1,3)-$EXTRACT(DOB,1,3)
+10 SET MD=$EXTRACT(DT,4,5)-$EXTRACT(DOB,4,5)
+11 SET DD=$EXTRACT(DT,6,7)-$EXTRACT(DOB,6,7)
+12 IF DD<0
SET MD=MD-1
+13 IF MD<1
SET MD=MD+12
SET YD=YD-1
+14 SET M=MD+(YD*12)
+15 IF M<2
QUIT 1
+16 QUIT M
+17 ;
DAGE(AM) ; EP - GIVEN AN AGE IN MONTHS, RETURN THE DISPLAY AGE
+1 NEW DAGE,M
+2 ;I AM<1 Q $$FMDIFF^XLFDT(DT,DOB,1)_" days old"
+3 IF AM<1
QUIT $$FMDIFF^XLFDT(DT,$PIECE(^DPT(DFN,0),U,3),1)_" days old"
+4 SET M=(AM#12)
+5 IF AM>35
QUIT (AM\12)_" years and "_M_" month"_$SELECT(M=1:"",1:"s")
+6 QUIT AM_" month"_$SELECT(AM=1:"",1:"s")
+7 QUIT DAGE
+8 ;
