Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHS6B

APCHS6B.m

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