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
