APCHS4A.m

APCHS4A ; IHS/CMI/LAB - PART 4A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

HFACT ; ******************** HEALTH FACTORS * 9000019 *********

 ; <SETUP>

 Q:'$D(^AUPNVHF("AC",APCHSPAT))

 S APCHSSNM=APCHSNDM,APCHSSDM=APCHSDLM

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 ; <DISPLAY>

 S APCHSHP=0

 I $O(^APCHSCTL(APCHSTYP,7,0)) D

 . S APCHSHFS="" F  S APCHSHFS=$O(^APCHSCTL(APCHSTYP,7,"B",APCHSHFS)) Q:'APCHSHFS  D

 .. S APCHSHFI="" F  S APCHSHFI=$O(^APCHSCTL(APCHSTYP,7,"B",APCHSHFS,APCHSHFI)) Q:'APCHSHFI  D

 ... S APCHSN=^APCHSCTL(APCHSTYP,7,APCHSHFI,0) S APCHSFC=$P(APCHSN,U,2),APCHSFT=$P(APCHSN,U,3),APCHSFD=$P(APCHSN,U,4) D ONECAT

 . Q

 E  D

 . S APCHSFC="" F  S APCHSFC=$O(^AUTTHF("AD","C",APCHSFC)) Q:'APCHSFC  S (APCHSFT,APCHSFD)="" D ONECAT

 . Q

 ; <CLEANUP>

HFACTX K APCHSCFI,APCHSDAT,APCHSDT2,APCHSFC,APCHSFD,APCHSFDP,APCHSFN,APCHSFSS,APCHSFT,APCHSFTB,APCHSHFI,APCHSHFS,APCHSHP,APCHSI,APCHSIVD,APCHSNDT,APCHSNI,APCHSPVD,APCHSSDM,APCHSSNM,APCHSTNP,Y,X

 Q

 ;

ONECAT ;

 S:APCHSFD="" APCHSFD="Y"

 S:APCHSFT="" APCHSFT=$P(^AUTTHF(APCHSFC,0),U)

 ;W "Category=",APCHSFC," Name=",$P(^AUTTHF(APCHSFC,0),U)," Title=",APCHSFT," Display=",APCHSFD,!

 S APCHSTNP=1

 K APCHSFTB

 S APCHSCFI="" F  S APCHSCFI=$O(^AUTTHF("AC",APCHSFC,APCHSCFI)) Q:'APCHSCFI  D ONEFACT

 D DISPDATA

 Q

ONEFACT ;

 S APCHSN=^AUTTHF(APCHSCFI,0),APCHSFN=$P(APCHSN,U)

 ;W ?3,APCHSN,!

 S APCHSNDM=APCHSSNM,APCHSDLM=APCHSSDM

 S APCHSPVD=0

 F APCHSIVD=0:0 S APCHSIVD=$O(^AUPNVHF("AA",APCHSPAT,APCHSCFI,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D ONEDATE Q:$D(APCHSQIT)  S:(APCHSDAT'=APCHSPVD) APCHSNDM=APCHSNDM-1,APCHSPVD=APCHSDAT Q:APCHSNDM=0  Q:APCHSFD="Y"

 Q

 ;

ONEDATE ;

 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y S APCHSNDT=(APCHSDAT'=APCHSPVD)

 D:APCHSTNP TPRINT

 S APCHSNI="" F  S APCHSNI=$O(^AUPNVHF("AA",APCHSPAT,APCHSCFI,APCHSIVD,APCHSNI)) Q:'APCHSNI  D SETFACT

 Q

SETFACT S APCHSN=^AUPNVHF(APCHSNI,0)

 S APCHSFSS="" S X=$P(APCHSN,U,4) I X]"" S Y=$P(^DD(9000019,.04,0),U,3) F APCHSI=1:1:$L(Y,";") S APCHSFDP=$P(Y,";",APCHSI) I X=$P(APCHSFDP,":") S APCHSFSS=$P(APCHSFDP,":",2) Q

 S APCHSQTY=$P(APCHSN,U,6)

 S APCHSFTB(APCHSIVD,APCHSDAT_U_APCHSFN_U_APCHSFSS_U_APCHSQTY_U_$P(APCHSN,U))=""

 Q

DISPDATA ; DISPLAY TABLED DATA

 S APCHSDT2=""

 S APCHSIVD=0 F  S APCHSIVD=$O(APCHSFTB(APCHSIVD)) Q:'APCHSIVD  S APCHSN="" F  S APCHSN=$O(APCHSFTB(APCHSIVD,APCHSN)) Q:APCHSN=""  D DISP2

 Q

DISP2 ;

 S APCHSDAT=$P(APCHSN,U),APCHSFN=$P(APCHSN,U,2),APCHSFSS=$P(APCHSN,U,3)

 W:APCHSDAT'=APCHSDT2 APCHSDAT W ?10,APCHSFN W:APCHSFSS]"" " (",APCHSFSS,")" D:$P(APCHSN,U,4)]"" WQTY W !

 S APCHSDT2=APCHSDAT

 Q

WQTY ;write out quantity and phrase

 NEW X S X=$P(APCHSN,U,5) Q:'X

 S X=$P(^AUTTHF(X,0),U,11)

 I X="" S X="QUANTITY"

 S X=X_": "

 W "  ",X,$P(APCHSN,U,4)

 Q

TPRINT ; PRINT TITLE

 S APCHSTNP=0

 W !,"~~ ",APCHSFT," ~~",! ;temporary

 Q

EDUCASSE ;EP - called from component educational assessment

 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK

 W !,"Most recent Health Factor recorded.",!

 W !,"   Learning Preference:  ",$$LASTHF^APCHSMU(APCHSPAT,"LEARNING PREFERENCE","B"),!

 ;X APCHSCKP Q:$D(APCHSQIT)

 ;W !,"    Readiness to Learn:  ",$$LASTHF^APCHSMU(APCHSPAT,"READINESS TO LEARN","B"),!

 X APCHSCKP Q:$D(APCHSQIT)

 W !,"  Barriers to Learning:  "

 S C=$O(^AUTTHF("B","BARRIERS TO LEARNING",0)) ;ien of category passed

 I '$G(C) Q

 S H=0 K APCHO

 F  S H=$O(^AUTTHF("AC",C,H))  Q:'+H  D

 .  Q:'$D(^AUPNVHF("AA",APCHSPAT,H))

 .  S D=$O(^AUPNVHF("AA",APCHSPAT,H,""))

 .  Q:'D

 .  S APCHO(H,D)=$O(^AUPNVHF("AA",APCHSPAT,H,D,""))

 .  Q

 S APCHX="" F  S APCHX=$O(APCHO(APCHX)) Q:APCHX=""!($D(APCHSQIT))  D

 .S D=$O(APCHO(APCHX,0))

 .X APCHSCKP Q:$D(APCHSQIT)

 .W ?25,$$VAL^XBDIQ1(9000010.23,APCHO(APCHX,D),.01)_"  "_$$FMTE^XLFDT((9999999-D)),!

 Q

APCHS4A   ; IHS/CMI/LAB - PART 4A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

HFACT     ; ******************** HEALTH FACTORS * 9000019 *********

 +1       ; <SETUP>

 +2        IF '$DATA(^AUPNVHF("AC",APCHSPAT))

               QUIT 

 +3        SET APCHSSNM=APCHSNDM

           SET APCHSSDM=APCHSDLM

 +4        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +5       ; <DISPLAY>

 +6        SET APCHSHP=0

 +7        IF $ORDER(^APCHSCTL(APCHSTYP,7,0))

               Begin DoDot:1

 +8                SET APCHSHFS=""

                   FOR 

                       SET APCHSHFS=$ORDER(^APCHSCTL(APCHSTYP,7,"B",APCHSHFS))

                       IF 'APCHSHFS

                           QUIT 

                       Begin DoDot:2

 +9                        SET APCHSHFI=""

                           FOR 

                               SET APCHSHFI=$ORDER(^APCHSCTL(APCHSTYP,7,"B",APCHSHFS,APCHSHFI))

                               IF 'APCHSHFI

                                   QUIT 

                               Begin DoDot:3

 +10                               SET APCHSN=^APCHSCTL(APCHSTYP,7,APCHSHFI,0)

                                   SET APCHSFC=$PIECE(APCHSN,U,2)

                                   SET APCHSFT=$PIECE(APCHSN,U,3)

                                   SET APCHSFD=$PIECE(APCHSN,U,4)

                                   DO ONECAT

                               End DoDot:3

                       End DoDot:2

 +11               QUIT 

               End DoDot:1

 +12      IF '$TEST

               Begin DoDot:1

 +13               SET APCHSFC=""

                   FOR 

                       SET APCHSFC=$ORDER(^AUTTHF("AD","C",APCHSFC))

                       IF 'APCHSFC

                           QUIT 

                       SET (APCHSFT,APCHSFD)=""

                       DO ONECAT

 +14               QUIT 

               End DoDot:1

 +15      ; <CLEANUP>

HFACTX     KILL APCHSCFI,APCHSDAT,APCHSDT2,APCHSFC,APCHSFD,APCHSFDP,APCHSFN,APCHSFSS,APCHSFT,APCHSFTB,APCHSHFI,APCHSHFS,APCHSHP,APCHSI,APCHSIVD,APCHSNDT,APCHSNI,APCHSPVD,APCHSSDM,APCHSSNM,APCHSTNP,Y,X

 +1        QUIT 

 +2       ;

ONECAT    ;

 +1        IF APCHSFD=""

               SET APCHSFD="Y"

 +2        IF APCHSFT=""

               SET APCHSFT=$PIECE(^AUTTHF(APCHSFC,0),U)

 +3       ;W "Category=",APCHSFC," Name=",$P(^AUTTHF(APCHSFC,0),U)," Title=",APCHSFT," Display=",APCHSFD,!

 +4        SET APCHSTNP=1

 +5        KILL APCHSFTB

 +6        SET APCHSCFI=""

           FOR 

               SET APCHSCFI=$ORDER(^AUTTHF("AC",APCHSFC,APCHSCFI))

               IF 'APCHSCFI

                   QUIT 

               DO ONEFACT

 +7        DO DISPDATA

 +8        QUIT 

ONEFACT   ;

 +1        SET APCHSN=^AUTTHF(APCHSCFI,0)

           SET APCHSFN=$PIECE(APCHSN,U)

 +2       ;W ?3,APCHSN,!

 +3        SET APCHSNDM=APCHSSNM

           SET APCHSDLM=APCHSSDM

 +4        SET APCHSPVD=0

 +5        FOR APCHSIVD=0:0

               SET APCHSIVD=$ORDER(^AUPNVHF("AA",APCHSPAT,APCHSCFI,APCHSIVD))

               IF APCHSIVD=""!(APCHSIVD>APCHSDLM)

                   QUIT 

               DO ONEDATE

               IF $DATA(APCHSQIT)

                   QUIT 

               IF (APCHSDAT'=APCHSPVD)

                   SET APCHSNDM=APCHSNDM-1

                   SET APCHSPVD=APCHSDAT

               IF APCHSNDM=0

                   QUIT 

               IF APCHSFD="Y"

                   QUIT 

 +6        QUIT 

 +7       ;

ONEDATE   ;

 +1        SET Y=-APCHSIVD\1+9999999

           XECUTE APCHSCVD

           SET APCHSDAT=Y

           SET APCHSNDT=(APCHSDAT'=APCHSPVD)

 +2        IF APCHSTNP

               DO TPRINT

 +3        SET APCHSNI=""

           FOR 

               SET APCHSNI=$ORDER(^AUPNVHF("AA",APCHSPAT,APCHSCFI,APCHSIVD,APCHSNI))

               IF 'APCHSNI

                   QUIT 

               DO SETFACT

 +4        QUIT 

SETFACT    SET APCHSN=^AUPNVHF(APCHSNI,0)

 +1        SET APCHSFSS=""

           SET X=$PIECE(APCHSN,U,4)

           IF X]""

               SET Y=$PIECE(^DD(9000019,.04,0),U,3)

               FOR APCHSI=1:1:$LENGTH(Y,";")

                   SET APCHSFDP=$PIECE(Y,";",APCHSI)

                   IF X=$PIECE(APCHSFDP,":")

                       SET APCHSFSS=$PIECE(APCHSFDP,":",2)

                       QUIT 

 +2        SET APCHSQTY=$PIECE(APCHSN,U,6)

 +3        SET APCHSFTB(APCHSIVD,APCHSDAT_U_APCHSFN_U_APCHSFSS_U_APCHSQTY_U_$PIECE(APCHSN,U))=""

 +4        QUIT 

DISPDATA  ; DISPLAY TABLED DATA

 +1        SET APCHSDT2=""

 +2        SET APCHSIVD=0

           FOR 

               SET APCHSIVD=$ORDER(APCHSFTB(APCHSIVD))

               IF 'APCHSIVD

                   QUIT 

               SET APCHSN=""

               FOR 

                   SET APCHSN=$ORDER(APCHSFTB(APCHSIVD,APCHSN))

                   IF APCHSN=""

                       QUIT 

                   DO DISP2

 +3        QUIT 

DISP2     ;

 +1        SET APCHSDAT=$PIECE(APCHSN,U)

           SET APCHSFN=$PIECE(APCHSN,U,2)

           SET APCHSFSS=$PIECE(APCHSN,U,3)

 +2        IF APCHSDAT'=APCHSDT2

               WRITE APCHSDAT

           WRITE ?10,APCHSFN

           IF APCHSFSS]""

               WRITE " (",APCHSFSS,")"

           IF $PIECE(APCHSN,U,4)]""

               DO WQTY

           WRITE !

 +3        SET APCHSDT2=APCHSDAT

 +4        QUIT 

WQTY      ;write out quantity and phrase

 +1        NEW X

           SET X=$PIECE(APCHSN,U,5)

           IF 'X

               QUIT 

 +2        SET X=$PIECE(^AUTTHF(X,0),U,11)

 +3        IF X=""

               SET X="QUANTITY"

 +4        SET X=X_": "

 +5        WRITE "  ",X,$PIECE(APCHSN,U,4)

 +6        QUIT 

TPRINT    ; PRINT TITLE

 +1        SET APCHSTNP=0

 +2       ;temporary

           WRITE !,"~~ ",APCHSFT," ~~",!

 +3        QUIT 

EDUCASSE  ;EP - called from component educational assessment

 +1        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

           IF 'APCHSNPG

               XECUTE APCHSBRK

 +2        WRITE !,"Most recent Health Factor recorded.",!

 +3        WRITE !,"   Learning Preference:  ",$$LASTHF^APCHSMU(APCHSPAT,"LEARNING PREFERENCE","B"),!

 +4       ;X APCHSCKP Q:$D(APCHSQIT)

 +5       ;W !,"    Readiness to Learn:  ",$$LASTHF^APCHSMU(APCHSPAT,"READINESS TO LEARN","B"),!

 +6        XECUTE APCHSCKP

           IF $DATA(APCHSQIT)

               QUIT 

 +7        WRITE !,"  Barriers to Learning:  "

 +8       ;ien of category passed

           SET C=$ORDER(^AUTTHF("B","BARRIERS TO LEARNING",0))

 +9        IF '$GET(C)

               QUIT 

 +10       SET H=0

           KILL APCHO

 +11       FOR 

               SET H=$ORDER(^AUTTHF("AC",C,H))

               IF '+H

                   QUIT 

               Begin DoDot:1

 +12               IF '$DATA(^AUPNVHF("AA",APCHSPAT,H))

                       QUIT 

 +13               SET D=$ORDER(^AUPNVHF("AA",APCHSPAT,H,""))

 +14               IF 'D

                       QUIT 

 +15               SET APCHO(H,D)=$ORDER(^AUPNVHF("AA",APCHSPAT,H,D,""))

 +16               QUIT 

               End DoDot:1

 +17       SET APCHX=""

           FOR 

               SET APCHX=$ORDER(APCHO(APCHX))

               IF APCHX=""!($DATA(APCHSQIT))

                   QUIT 

               Begin DoDot:1

 +18               SET D=$ORDER(APCHO(APCHX,0))

 +19               XECUTE APCHSCKP

                   IF $DATA(APCHSQIT)

                       QUIT 

 +20               WRITE ?25,$$VAL^XBDIQ1(9000010.23,APCHO(APCHX,D),.01)_"  "_$$FMTE^XLFDT((9999999-D)),!

               End DoDot:1

 +21       QUIT