APCHS61 ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS 18 Jun 2008 10:07 AM ;
;;2.0;IHS PCC SUITE;**7,10,11**;MAY 14, 2009;Build 58
;
;
FMH ;EP - ******* FAMILY HISTORY * 9000014 *******
; <SETUP>
I '$D(^AUPNFH("AC",APCHSPAT)),'$D(^AUPNFHR("AA",APCHSPAT)) Q ;no family history to display
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
K APCHTFH
S APCHSDFN=0 F S APCHSDFN=$O(^AUPNFH("AC",APCHSPAT,APCHSDFN)) Q:'APCHSDFN D
.Q:'$D(^AUPNFH(APCHSDFN,0)) ;bad xref
.S R=$P(^AUPNFH(APCHSDFN,0),U,9)
.I R="" S R="Z",S=$$VAL^XBDIQ1(9000014,APCHSDFN,.07),Z=S_" ",O=8 D G FMH1
..I S="" S S="UNKNOWN",Z="UNKNOWN "
.S S=$$VAL^XBDIQ1(9000014.1,R,.01),Z=S_" "_$P(^AUPNFHR(R,0),U,3)
.S O=$P(^AUPNFHR(R,0),U) I O S O=$P($G(^AUTTRLSH(O,21)),U,3)
.I 'O S O=8
FMH1 .S APCHTFH(O,S,Z,R,(9999999-$$LDM(APCHSDFN)),APCHSDFN)=""
;get relations with no conditions
S X=0 F S X=$O(^AUPNFHR("AA",APCHSPAT,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNFHR("AA",APCHSPAT,X,Y)) Q:Y'=+Y D
.I '$D(^AUPNFH("AE",Y)) D
..S R=Y
..S S=$$VAL^XBDIQ1(9000014.1,R,.01),Z=S_" "_$P(^AUPNFHR(R,0),U,3)
..S O=$P(^AUPNFHR(R,0),U) I O S O=$P($G(^AUTTRLSH(O,21)),U,3)
..I 'O S O=8
..S APCHTFH(O,S,Z,R,(9999999-$P(^AUPNFHR(R,0),U,9)),0)=""
W "Date Last Mod",?14,"Relation/Status/Diagnosis"
S APCHO=0 F S APCHO=$O(APCHTFH(APCHO)) Q:APCHO'=+APCHO D FMH2
FMHX K APCHSDFN,APCHSN,APCHSICD,APCHSDAT,APCHSNRQ,APCHSICL,APCHSDFN,APCHTFH,APCHS,APCHZ,APCHR,APCHD
Q
LDM(I) ;get last date modified of Family History or relation
I $G(I)="" Q ""
I '$D(^AUPNFH(I,0)) Q ""
NEW J,D,E
S D=""
S J=$P(^AUPNFH(I,0),U,9) I J S D=$P($G(^AUPNFHR(J,0)),U,9) I D="" S D=$P($G(^AUPNFHR(J,0)),U,9)
S E=$P(^AUPNFH(I,0),U,12) I E>D S D=E
S E=$P(^AUPNFH(I,0),U,3) I E>D S D=E
Q D
FMH2 ;
S APCHS="",APCHC=0 F S APCHS=$O(APCHTFH(APCHO,APCHS)) Q:APCHS=""!($D(APCHSQIT)) D
.S APCHZ="" F S APCHZ=$O(APCHTFH(APCHO,APCHS,APCHZ)) Q:APCHZ=""!($D(APCHSQIT)) D
..S APCHR="" F S APCHR=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR)) Q:APCHR=""!($D(APCHSQIT)) D
...S APCHTD=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,0)),APCHTD=(9999999-APCHTD) S Y=APCHTD X APCHSCVD S APCHTDAT=Y S:APCHTDAT="/" APCHTDAT=""
...S APCHD="",APCHC=0 F S APCHD=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD)) Q:APCHD=""!($D(APCHSQIT)) D
....S APCHSDFN="" F S APCHSDFN=$O(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD,APCHSDFN)) Q:APCHSDFN=""!($D(APCHSQIT)) D FHDSP
;S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNFH("AC",APCHSPAT,APCHSDFN)) Q:APCHSDFN="" D FHDSP
; <CLEANUP>
Q
FHDSP S APCHC=APCHC+1
I APCHC=1 W !,APCHTDAT,?14,APCHZ," Status: "
S APCHSTAT=""
I 'APCHR,APCHSDFN D
.S APCHSTAT=$S($P(^AUPNFH(APCHSDFN,0),U,6)]"":$$VAL^XBDIQ1(9000014,APCHSDFN,.06),1:"None")
I APCHR S APCHSTAT=$S($P($G(^AUPNFHR(APCHR,0)),U,4)]"":$$VAL^XBDIQ1(9000014.1,APCHR,.04),1:"None")
I APCHC=1 W APCHSTAT,!
I APCHR,$P(^AUPNFHR(APCHR,0),U,5)]""!($P(^AUPNFHR(APCHR,0),U,6)]"") D
.I APCHC=1 W ?14,"Age at Death: ",$$VAL^XBDIQ1(9000014.1,APCHR,.05)," Cause of Death: ",$S($P(^AUPNFHR(APCHR,0),U,6)]"":$P(^AUPNFHR(APCHR,0),U,6),1:"Data Not Available"),!
I APCHR,$P(^AUPNFHR(APCHR,0),U,7)]""!($P(^AUPNFHR(APCHR,0),U,8)]"") D
.I APCHC=1 W ?14,"Multiple Birth: "_$$VAL^XBDIQ1(9000014.1,APCHR,.07)_$S($P(^AUPNFHR(APCHR,0),U,7)="Y":" Multiple Birth Type: "_$$VAL^XBDIQ1(9000014.1,APCHR,.08),1:""),! ;_" Date Updated: "_$$VAL^XBDIQ1(9000014.1,R,.09)
Q:'APCHSDFN
S APCHSN=^AUPNFH(APCHSDFN,0)
S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
;S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDAT=Y
S APCHSNRQ=$P(APCHSN,U,4)
S APCHSNRQ=$$PNPROB^AUPNVUTL(APCHSNRQ) ;D GETNARR^APCHSUTL
X APCHSCKP Q:$D(APCHSQIT) ; W !,APCHSDAT
S (X,R,S,N,A,P)=""
;S R=$$VAL^XBDIQ1(9000014,APCHSDFN,.07)
S APCHSNRQ=APCHSNRQ ;_" ("_$$VAL^XBDIQ1(9000014,APCHSDFN,.01)_")"
S A="" I APCHSDFN S A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05) I $P(^AUPNFH(APCHSDFN,0),U,15) S A=A_" (APPROXIMATE)" ;I A="" S A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05)
;S S=$$VAL^XBDIQ1(9000014,APCHSDFN,.06)
;S P=$$VAL^XBDIQ1(9000014,APCHSDFN,.08)
;S X=R
;I X]"" S X=X_"; "
S X=APCHSNRQ
S X=X_$S(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
;S X=X_$S(S]"":"; Status: "_S,1:"; Status: None")
;S X=X_$S(P]"":"; Documented By: "_P,1:"")
S APCHSICL=14,APCHSNRQ=X
D PRTICD^APCHSUTL
Q
;
PWH ;EP - called from component Patient wellness Handout
; <SETUP>
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
K APCHTFH
S APCHSIVD="" F S APCHSIVD=$O(^APCHPWHL("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
.S APCHIEN=0 F S APCHIEN=$O(^APCHPWHL("AA",APCHSPAT,APCHSIVD,APCHIEN)) Q:APCHIEN'=+APCHIEN D
..S APCHSN=$G(^APCHPWHL(APCHIEN,0))
..I APCHSN="" Q
..S N=$$VAL^XBDIQ1(9001027,APCHIEN,.02)
..S $P(APCHTFH(N),U)=$P($G(APCHTFH(N)),U)+1
..S P=$P(APCHTFH(N),U)+1
..S $P(APCHTFH(N),U,P)=$$DATE^APCHSMU($P(^APCHPWHL(APCHIEN,0),U,4))
;now display
I '$D(APCHTFH) W "No Patient Wellness Handouts given to this patient.",! Q
W ?2,"PATIENT WELLNESS HANDOUT TYPE",?34,"# given",?42,"Dates Last 4 Given to Patient",!
W $$REPEAT^XLFSTR("-",79),!
S APCHSN="" F S APCHSN=$O(APCHTFH(APCHSN)) Q:APCHSN=""!($D(APCHSQIT)) D
.S O=$P(APCHTFH(APCHSN),U,2,99)
.S N=$L(O,U)
.W ?2,APCHSN,?34,$P(APCHTFH(APCHSN),U) W ?42,$P(O,U,N)," ",$P(O,U,N-1)," ",$P(O,U,N-2)," ",$P(O,U,N-3),!
.Q
K APCHTFH,APCHSN
Q
AMI ;EP - called from health summary AMI component
K APCHSTXA
; <SETUP>
Q:'$D(^AUPNVAMI("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT)
S APCHARR=9999999999,APCHSDLZ=9999999-APCHSDLM
F S APCHARR=$O(^AUPNVAMI("AA",APCHSPAT,APCHARR),-1) Q:APCHARR=""!($P(APCHARR,".")<APCHSDLZ) D
.S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVAMI("AA",APCHSPAT,APCHARR,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
..;table them by date,problem or problem,date depending on the component
..S X=0 F S X=$O(^AUPNVAMI("AA",APCHSPAT,APCHARR,APCHSIVD,X)) Q:X'=+X D
...Q:$P($G(^AUPNVAMI(X,5)),U,1) ;entered in error
...S D=9999999-$P(+^AUPNVAMI(X,0),".",1)
...S APCHSTXA("DATE",D,X)=""
D WRITEAMI
; <CLEANUP>
AMIX K APCHARR,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ
Q
WP ;
K ^UTILITY($J,"W")
I '$O(^AUPNVAMI(APCHX,2,0)) W ! Q
NEW APCHY
S APCHY=0
S DIWL=17,DIWR=79 F S APCHY=$O(^AUPNVAMI(APCHX,2,APCHY)) Q:APCHY'=+APCHY D
.S X=^AUPNVAMI(APCHX,2,APCHY,0) D ^DIWP
.Q
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?17,^UTILITY($J,"W",DIWL,Z,0),!
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),APCHY
Q
WRITEAMI ;
S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA("DATE",APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT)
.S APCHX=0 F S APCHX=$O(APCHSTXA("DATE",APCHSIVD,APCHX)) Q:APCHX=""!($D(APCHSQIT)) D
..W ?3,"Arrived at: ",$$GET1^DIQ(9000010.62,APCHX,.01),!
..W ?3,"Onset of symptoms: ",$$GET1^DIQ(9000010.62,APCHX,.04),!
..W ?6,"Symptoms: "
..D WP
..W ?3,"EKG done: ",$$GET1^DIQ(9000010.62,APCHX,.07),!
..;loop through 14 node and display EKG findings
..;.01 concept id ,.02 DESC id | .03,, .06 interpreted by
..S APCHY=0 F S APCHY=$O(^AUPNVAMI(APCHX,14,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT)) D
...;X APCHSCKP Q:$D(APCHSQIT)
...S APCHZ=$G(^AUPNVAMI(APCHX,14,APCHY,0))
...;W ?6,$$CONCPT^AUPNVUTL($P(APCHZ,U,1)),!
...S X="EKG Interpretation: "_$$DESCPT^AUPNVUTL($P(APCHZ,U,2))_"|"_$$GET1^DIQ(9000010.6214,APCHY_","_APCHX,.03)
...S APCHSNRQ="",APCHSTXT=X,APCHSICL=6 D PRTTXT^APCHSUTL
...X APCHSCKP Q:$D(APCHSQIT)
...W ?6,"Interpreted by: ",$$GET1^DIQ(9000010.6214,APCHY_","_APCHX,.06),!
..;loop through 13 node and display protocols initiated
..;.01 free text ,.02 date/time, .03 entered by
..X APCHSCKP Q:$D(APCHSQIT)
..W ?3,"Standing orders/Protocols Initiated",!
..S APCHY=0 F S APCHY=$O(^AUPNVAMI(APCHX,13,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT)) D
...X APCHSCKP Q:$D(APCHSQIT)
...S APCHZ=^AUPNVAMI(APCHX,13,APCHY,0)
...S X=$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.01)_" "_$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.02)_" by "_$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.04)
...S APCHSNRQ="",APCHSTXT=X,APCHSICL=6 D PRTTXT^APCHSUTL
..I $P(^AUPNVAMI(APCHX,0),U,11)]"" W ?3,"Fibrinolytic therapy started at: ",$$GET1^DIQ(9000010.62,APCHX,.11)," by ",$$GET1^DIQ(9000010.62,APCHX,.13),!
..I $P(^AUPNVAMI(APCHX,0),U,14)]"" D
...W ?3,"Fibrinolytic Not Started: ",$$GET1^DIQ(9000010.62,APCHX,.14)," by ",$$GET1^DIQ(9000010.62,APCHX,.16),!
...W ?3,"Reason Not Started: ",$$GET1^DIQ(9000010.62,APCHX,.17),!
.W !
Q
STROKE ;EP - called from component
K APCHSTXA
; <SETUP>
Q:'$D(^AUPNVSTR("AA",APCHSPAT)) ;no stroke data
X APCHSBRK
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT)
S APCHARR=9999999999,APCHSDLZ=9999999-APCHSDLM
F S APCHARR=$O(^AUPNVSTR("AA",APCHSPAT,APCHARR),-1) Q:APCHARR=""!($P(APCHARR,".")<APCHSDLZ) D
.S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVSTR("AA",APCHSPAT,APCHARR,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
..;table them by date,problem or problem,date depending on the component
..S X=0 F S X=$O(^AUPNVSTR("AA",APCHSPAT,APCHARR,APCHSIVD,X)) Q:X'=+X D
...Q:$P($G(^AUPNVSTR(X,5)),U,1) ;entered in error
...S D=9999999-$P(+^AUPNVSTR(X,0),".",1)
...S APCHSTXA("DATE",D,X)=""
D WRITEST
; <CLEANUP>
STROKEX K APCHARR,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ,APCHNODE
Q
WPSTR ;
K ^UTILITY($J,"W")
I '$O(^AUPNVSTR(APCHX,APCHNODE,0)) W ! Q
NEW APCHY
S APCHY=0
S DIWL=17,DIWR=79 F S APCHY=$O(^AUPNVSTR(APCHX,APCHNODE,APCHY)) Q:APCHY'=+APCHY D
.S X=^AUPNVSTR(APCHX,APCHNODE,APCHY,0) D ^DIWP
.Q
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?17,^UTILITY($J,"W",DIWL,Z,0),!
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),APCHY
Q
WRITEST ;
S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA("DATE",APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT)
.S APCHX=0 F S APCHX=$O(APCHSTXA("DATE",APCHSIVD,APCHX)) Q:APCHX=""!($D(APCHSQIT)) D
..W ?3,"Arrived at: ",$$GET1^DIQ(9000010.63,APCHX,.01),!
..W ?6,"Symptoms: "
..;loop through 14 node and display SYMPTOMS findings
..;.01 concept id ,.02 DESC id | .03,, .0 WITNESSED by
..S APCHY=0 F S APCHY=$O(^AUPNVSTR(APCHX,14,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT)) D
...;X APCHSCKP Q:$D(APCHSQIT)
...S APCHZ=^AUPNVSTR(APCHX,14,APCHY,0)
...W ?6,$$CONCPT^AUPNVUTL($P(APCHZ,U,1)),!
...S X=$$DESCPT^AUPNVUTL($P(APCHZ,U,2))_"|"_$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.03)
...S APCHSNRQ="",APCHSTXT=X,APCHSICL=6 D PRTTXT^APCHSUTL
...X APCHSCKP Q:$D(APCHSQIT)
...W ?6,"Witnessed by: ",$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.07),!
...W ?6,"Date/Time Witnessed: ",$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.08),!
..;handedness
..X APCHSCKP Q:$D(APCHSQIT)
..S APCHY=0,APCHZ="" F S APCHY=$O(^AUPNVSTR(APCHX,2,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT)) D
...S:APCHZ]"" APCHZ=APCHZ_"; "
...S APCHZ=APCHZ_$$GET1^DIQ(9000010.632,APCHY_","_APCHX,.019)
..W ?6,"Handedness: ",APCHZ,!
..;loop through 13 node and display protocols initiated
..;.01 free text ,.02 date/time, .03 entered by
..X APCHSCKP Q:$D(APCHSQIT)
..S APCHY=$$WT(APCHX)
..I APCHY]"" W ?6,"Weight: ",$P(APCHY,U)," lbs ("_$P(APCHY,U,2),")",!
..;X APCHSCKP Q:$D(APCHSQIT)
..;total score stroke
..S APCHY=0 F S APCHY=$O(^AUPNVSTR(APCHX,15,APCHY)) Q:APCHY'=+APCHY!($D(APCHQIT)) D
...X APCHSCKP Q:$D(APCHSQIT)
...W ?6,"Stroke Score: ",$$GET1^DIQ(9000010.6315,APCHY_","_APCHX,.19)," @ ",$$GET1^DIQ(9000010.6315,APCHY_","_APCHX,.02),!
..X APCHSCKP Q:$D(APCHSQIT)
..W ?3,"Standing orders/Protocols Initiated",!
..S APCHY=0 F S APCHY=$O(^AUPNVSTR(APCHX,13,APCHY)) Q:APCHY'=+APCHY!($D(APCHSQIT)) D
...X APCHSCKP Q:$D(APCHSQIT)
...S APCHZ=^AUPNVSTR(APCHX,13,APCHY,0)
...S X=$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.01)_" "_$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.02)_" by "_$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.04)
...S APCHSNRQ="",APCHSTXT=X,APCHSICL=6 D PRTTXT^APCHSUTL
..I $P(^AUPNVSTR(APCHX,0),U,11)]"" W ?3,"Fibrinolytic therapy started at: ",$$GET1^DIQ(9000010.63,APCHX,.11)," by ",$$GET1^DIQ(9000010.3,APCHX,.13),!
..I $P(^AUPNVSTR(APCHX,0),U,14)]"" D
...W ?3,"Fibrinolytic Not Started: ",$$GET1^DIQ(9000010.63,APCHX,.14)," by ",$$GET1^DIQ(9000010.63,APCHX,.16),!
...W ?3,"Reason Not Started: ",$$GET1^DIQ(9000010.63,APCHX,.17),!
.W !
Q
WT(V) ;IS THERE A WEIGHT ON THIS DATE?
NEW D,A,B,C,P
S A=$$VALI^XBDIQ1(9000010.63,V,.03)
I 'A Q ""
I '$D(^AUPNVSIT(A,0)) Q ""
S D=$P($P(^AUPNVSIT(A,0),U),".")
S P=$$VALI^XBDIQ1(9000010.63,V,.02)
I 'P Q ""
S C=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",D,D,"A")
I C="" Q ""
Q $P(C,U,3)_U_$$VAL^XBDIQ1(9000010.01,$P(C,U,6),1201)
APCHS61 ; IHS/CMI/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS 18 Jun 2008 10:07 AM ;
+1 ;;2.0;IHS PCC SUITE;**7,10,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
FMH ;EP - ******* FAMILY HISTORY * 9000014 *******
+1 ; <SETUP>
+2 ;no family history to display
IF '$DATA(^AUPNFH("AC",APCHSPAT))
IF '$DATA(^AUPNFHR("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 KILL APCHTFH
+6 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNFH("AC",APCHSPAT,APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:1
+7 ;bad xref
IF '$DATA(^AUPNFH(APCHSDFN,0))
QUIT
+8 SET R=$PIECE(^AUPNFH(APCHSDFN,0),U,9)
+9 IF R=""
SET R="Z"
SET S=$$VAL^XBDIQ1(9000014,APCHSDFN,.07)
SET Z=S_" "
SET O=8
Begin DoDot:2
+10 IF S=""
SET S="UNKNOWN"
SET Z="UNKNOWN "
End DoDot:2
GOTO FMH1
+11 SET S=$$VAL^XBDIQ1(9000014.1,R,.01)
SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)
+12 SET O=$PIECE(^AUPNFHR(R,0),U)
IF O
SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)
+13 IF 'O
SET O=8
FMH1 SET APCHTFH(O,S,Z,R,(9999999-$$LDM(APCHSDFN)),APCHSDFN)=""
End DoDot:1
+1 ;get relations with no conditions
+2 SET X=0
FOR
SET X=$ORDER(^AUPNFHR("AA",APCHSPAT,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNFHR("AA",APCHSPAT,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNFH("AE",Y))
Begin DoDot:2
+4 SET R=Y
+5 SET S=$$VAL^XBDIQ1(9000014.1,R,.01)
SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)
+6 SET O=$PIECE(^AUPNFHR(R,0),U)
IF O
SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)
+7 IF 'O
SET O=8
+8 SET APCHTFH(O,S,Z,R,(9999999-$PIECE(^AUPNFHR(R,0),U,9)),0)=""
End DoDot:2
End DoDot:1
+9 WRITE "Date Last Mod",?14,"Relation/Status/Diagnosis"
+10 SET APCHO=0
FOR
SET APCHO=$ORDER(APCHTFH(APCHO))
IF APCHO'=+APCHO
QUIT
DO FMH2
FMHX KILL APCHSDFN,APCHSN,APCHSICD,APCHSDAT,APCHSNRQ,APCHSICL,APCHSDFN,APCHTFH,APCHS,APCHZ,APCHR,APCHD
+1 QUIT
LDM(I) ;get last date modified of Family History or relation
+1 IF $GET(I)=""
QUIT ""
+2 IF '$DATA(^AUPNFH(I,0))
QUIT ""
+3 NEW J,D,E
+4 SET D=""
+5 SET J=$PIECE(^AUPNFH(I,0),U,9)
IF J
SET D=$PIECE($GET(^AUPNFHR(J,0)),U,9)
IF D=""
SET D=$PIECE($GET(^AUPNFHR(J,0)),U,9)
+6 SET E=$PIECE(^AUPNFH(I,0),U,12)
IF E>D
SET D=E
+7 SET E=$PIECE(^AUPNFH(I,0),U,3)
IF E>D
SET D=E
+8 QUIT D
FMH2 ;
+1 SET APCHS=""
SET APCHC=0
FOR
SET APCHS=$ORDER(APCHTFH(APCHO,APCHS))
IF APCHS=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+2 SET APCHZ=""
FOR
SET APCHZ=$ORDER(APCHTFH(APCHO,APCHS,APCHZ))
IF APCHZ=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+3 SET APCHR=""
FOR
SET APCHR=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR))
IF APCHR=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+4 SET APCHTD=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR,0))
SET APCHTD=(9999999-APCHTD)
SET Y=APCHTD
XECUTE APCHSCVD
SET APCHTDAT=Y
IF APCHTDAT="/"
SET APCHTDAT=""
+5 SET APCHD=""
SET APCHC=0
FOR
SET APCHD=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD))
IF APCHD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+6 SET APCHSDFN=""
FOR
SET APCHSDFN=$ORDER(APCHTFH(APCHO,APCHS,APCHZ,APCHR,APCHD,APCHSDFN))
IF APCHSDFN=""!($DATA(APCHSQIT))
QUIT
DO FHDSP
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNFH("AC",APCHSPAT,APCHSDFN)) Q:APCHSDFN="" D FHDSP
+8 ; <CLEANUP>
+9 QUIT
FHDSP SET APCHC=APCHC+1
+1 IF APCHC=1
WRITE !,APCHTDAT,?14,APCHZ," Status: "
+2 SET APCHSTAT=""
+3 IF 'APCHR
IF APCHSDFN
Begin DoDot:1
+4 SET APCHSTAT=$SELECT($PIECE(^AUPNFH(APCHSDFN,0),U,6)]"":$$VAL^XBDIQ1(9000014,APCHSDFN,.06),1:"None")
End DoDot:1
+5 IF APCHR
SET APCHSTAT=$SELECT($PIECE($GET(^AUPNFHR(APCHR,0)),U,4)]"":$$VAL^XBDIQ1(9000014.1,APCHR,.04),1:"None")
+6 IF APCHC=1
WRITE APCHSTAT,!
+7 IF APCHR
IF $PIECE(^AUPNFHR(APCHR,0),U,5)]""!($PIECE(^AUPNFHR(APCHR,0),U,6)]"")
Begin DoDot:1
+8 IF APCHC=1
WRITE ?14,"Age at Death: ",$$VAL^XBDIQ1(9000014.1,APCHR,.05)," Cause of Death: ",$SELECT($PIECE(^AUPNFHR(APCHR,0),U,6)]"":$PIECE(^AUPNFHR(APCHR,0),U,6),1:"Data Not Available"),!
End DoDot:1
+9 IF APCHR
IF $PIECE(^AUPNFHR(APCHR,0),U,7)]""!($PIECE(^AUPNFHR(APCHR,0),U,8)]"")
Begin DoDot:1
+10 ;_" Date Updated: "_$$VAL^XBDIQ1(9000014.1,R,.09)
IF APCHC=1
WRITE ?14,"Multiple Birth: "_$$VAL^XBDIQ1(9000014.1,APCHR,.07)_$SELECT($PIECE(^AUPNFHR(APCHR,0),U,7)="Y":" Multiple Birth Type: "_$$VAL^XBDIQ1(9000014.1,APCHR,.08),1:""),!
End DoDot:1
+11 IF 'APCHSDFN
QUIT
+12 SET APCHSN=^AUPNFH(APCHSDFN,0)
+13 SET APCHSICD=$PIECE(APCHSN,U,1)
DO GETICDDX^APCHSUTL
+14 ;S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDAT=Y
+15 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+16 ;D GETNARR^APCHSUTL
SET APCHSNRQ=$$PNPROB^AUPNVUTL(APCHSNRQ)
+17 ; W !,APCHSDAT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+18 SET (X,R,S,N,A,P)=""
+19 ;S R=$$VAL^XBDIQ1(9000014,APCHSDFN,.07)
+20 ;_" ("_$$VAL^XBDIQ1(9000014,APCHSDFN,.01)_")"
SET APCHSNRQ=APCHSNRQ
+21 ;I A="" S A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05)
SET A=""
IF APCHSDFN
SET A=$$VAL^XBDIQ1(9000014,APCHSDFN,.05)
IF $PIECE(^AUPNFH(APCHSDFN,0),U,15)
SET A=A_" (APPROXIMATE)"
+22 ;S S=$$VAL^XBDIQ1(9000014,APCHSDFN,.06)
+23 ;S P=$$VAL^XBDIQ1(9000014,APCHSDFN,.08)
+24 ;S X=R
+25 ;I X]"" S X=X_"; "
+26 SET X=APCHSNRQ
+27 SET X=X_$SELECT(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
+28 ;S X=X_$S(S]"":"; Status: "_S,1:"; Status: None")
+29 ;S X=X_$S(P]"":"; Documented By: "_P,1:"")
+30 SET APCHSICL=14
SET APCHSNRQ=X
+31 DO PRTICD^APCHSUTL
+32 QUIT
+33 ;
PWH ;EP - called from component Patient wellness Handout
+1 ; <SETUP>
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+3 ; <DISPLAY>
+4 KILL APCHTFH
+5 SET APCHSIVD=""
FOR
SET APCHSIVD=$ORDER(^APCHPWHL("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:1
+6 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(^APCHPWHL("AA",APCHSPAT,APCHSIVD,APCHIEN))
IF APCHIEN'=+APCHIEN
QUIT
Begin DoDot:2
+7 SET APCHSN=$GET(^APCHPWHL(APCHIEN,0))
+8 IF APCHSN=""
QUIT
+9 SET N=$$VAL^XBDIQ1(9001027,APCHIEN,.02)
+10 SET $PIECE(APCHTFH(N),U)=$PIECE($GET(APCHTFH(N)),U)+1
+11 SET P=$PIECE(APCHTFH(N),U)+1
+12 SET $PIECE(APCHTFH(N),U,P)=$$DATE^APCHSMU($PIECE(^APCHPWHL(APCHIEN,0),U,4))
End DoDot:2
End DoDot:1
+13 ;now display
+14 IF '$DATA(APCHTFH)
WRITE "No Patient Wellness Handouts given to this patient.",!
QUIT
+15 WRITE ?2,"PATIENT WELLNESS HANDOUT TYPE",?34,"# given",?42,"Dates Last 4 Given to Patient",!
+16 WRITE $$REPEAT^XLFSTR("-",79),!
+17 SET APCHSN=""
FOR
SET APCHSN=$ORDER(APCHTFH(APCHSN))
IF APCHSN=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+18 SET O=$PIECE(APCHTFH(APCHSN),U,2,99)
+19 SET N=$LENGTH(O,U)
+20 WRITE ?2,APCHSN,?34,$PIECE(APCHTFH(APCHSN),U)
WRITE ?42,$PIECE(O,U,N)," ",$PIECE(O,U,N-1)," ",$PIECE(O,U,N-2)," ",$PIECE(O,U,N-3),!
+21 QUIT
End DoDot:1
+22 KILL APCHTFH,APCHSN
+23 QUIT
AMI ;EP - called from health summary AMI component
+1 KILL APCHSTXA
+2 ; <SETUP>
+3 IF '$DATA(^AUPNVAMI("AA",APCHSPAT))
QUIT
+4 XECUTE APCHSBRK
+5 ; <DISPLAY>
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 SET APCHARR=9999999999
SET APCHSDLZ=9999999-APCHSDLM
+8 FOR
SET APCHARR=$ORDER(^AUPNVAMI("AA",APCHSPAT,APCHARR),-1)
IF APCHARR=""!($PIECE(APCHARR,".")<APCHSDLZ)
QUIT
Begin DoDot:1
+9 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVAMI("AA",APCHSPAT,APCHARR,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:2
+10 ;table them by date,problem or problem,date depending on the component
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVAMI("AA",APCHSPAT,APCHARR,APCHSIVD,X))
IF X'=+X
QUIT
Begin DoDot:3
+12 ;entered in error
IF $PIECE($GET(^AUPNVAMI(X,5)),U,1)
QUIT
+13 SET D=9999999-$PIECE(+^AUPNVAMI(X,0),".",1)
+14 SET APCHSTXA("DATE",D,X)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 DO WRITEAMI
+16 ; <CLEANUP>
AMIX KILL APCHARR,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ
+1 QUIT
WP ;
+1 KILL ^UTILITY($JOB,"W")
+2 IF '$ORDER(^AUPNVAMI(APCHX,2,0))
WRITE !
QUIT
+3 NEW APCHY
+4 SET APCHY=0
+5 SET DIWL=17
SET DIWR=79
FOR
SET APCHY=$ORDER(^AUPNVAMI(APCHX,2,APCHY))
IF APCHY'=+APCHY
QUIT
Begin DoDot:1
+6 SET X=^AUPNVAMI(APCHX,2,APCHY,0)
DO ^DIWP
+7 QUIT
End DoDot:1
+8 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 WRITE ?17,^UTILITY($JOB,"W",DIWL,Z,0),!
End DoDot:1
+11 KILL DIWL,DIWR,DIWF,Z
+12 KILL ^UTILITY($JOB,"W"),APCHY
+13 QUIT
WRITEAMI ;
+1 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA("DATE",APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHSTXA("DATE",APCHSIVD,APCHX))
IF APCHX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+4 WRITE ?3,"Arrived at: ",$$GET1^DIQ(9000010.62,APCHX,.01),!
+5 WRITE ?3,"Onset of symptoms: ",$$GET1^DIQ(9000010.62,APCHX,.04),!
+6 WRITE ?6,"Symptoms: "
+7 DO WP
+8 WRITE ?3,"EKG done: ",$$GET1^DIQ(9000010.62,APCHX,.07),!
+9 ;loop through 14 node and display EKG findings
+10 ;.01 concept id ,.02 DESC id | .03,, .06 interpreted by
+11 SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNVAMI(APCHX,14,APCHY))
IF APCHY'=+APCHY!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+12 ;X APCHSCKP Q:$D(APCHSQIT)
+13 SET APCHZ=$GET(^AUPNVAMI(APCHX,14,APCHY,0))
+14 ;W ?6,$$CONCPT^AUPNVUTL($P(APCHZ,U,1)),!
+15 SET X="EKG Interpretation: "_$$DESCPT^AUPNVUTL($PIECE(APCHZ,U,2))_"|"_$$GET1^DIQ(9000010.6214,APCHY_","_APCHX,.03)
+16 SET APCHSNRQ=""
SET APCHSTXT=X
SET APCHSICL=6
DO PRTTXT^APCHSUTL
+17 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+18 WRITE ?6,"Interpreted by: ",$$GET1^DIQ(9000010.6214,APCHY_","_APCHX,.06),!
End DoDot:3
+19 ;loop through 13 node and display protocols initiated
+20 ;.01 free text ,.02 date/time, .03 entered by
+21 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+22 WRITE ?3,"Standing orders/Protocols Initiated",!
+23 SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNVAMI(APCHX,13,APCHY))
IF APCHY'=+APCHY!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+24 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+25 SET APCHZ=^AUPNVAMI(APCHX,13,APCHY,0)
+26 SET X=$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.01)_" "_$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.02)_" by "_$$GET1^DIQ(9000010.6213,APCHY_","_APCHX,.04)
+27 SET APCHSNRQ=""
SET APCHSTXT=X
SET APCHSICL=6
DO PRTTXT^APCHSUTL
End DoDot:3
+28 IF $PIECE(^AUPNVAMI(APCHX,0),U,11)]""
WRITE ?3,"Fibrinolytic therapy started at: ",$$GET1^DIQ(9000010.62,APCHX,.11)," by ",$$GET1^DIQ(9000010.62,APCHX,.13),!
+29 IF $PIECE(^AUPNVAMI(APCHX,0),U,14)]""
Begin DoDot:3
+30 WRITE ?3,"Fibrinolytic Not Started: ",$$GET1^DIQ(9000010.62,APCHX,.14)," by ",$$GET1^DIQ(9000010.62,APCHX,.16),!
+31 WRITE ?3,"Reason Not Started: ",$$GET1^DIQ(9000010.62,APCHX,.17),!
End DoDot:3
End DoDot:2
+32 WRITE !
End DoDot:1
+33 QUIT
STROKE ;EP - called from component
+1 KILL APCHSTXA
+2 ; <SETUP>
+3 ;no stroke data
IF '$DATA(^AUPNVSTR("AA",APCHSPAT))
QUIT
+4 XECUTE APCHSBRK
+5 ; <DISPLAY>
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 SET APCHARR=9999999999
SET APCHSDLZ=9999999-APCHSDLM
+8 FOR
SET APCHARR=$ORDER(^AUPNVSTR("AA",APCHSPAT,APCHARR),-1)
IF APCHARR=""!($PIECE(APCHARR,".")<APCHSDLZ)
QUIT
Begin DoDot:1
+9 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVSTR("AA",APCHSPAT,APCHARR,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:2
+10 ;table them by date,problem or problem,date depending on the component
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVSTR("AA",APCHSPAT,APCHARR,APCHSIVD,X))
IF X'=+X
QUIT
Begin DoDot:3
+12 ;entered in error
IF $PIECE($GET(^AUPNVSTR(X,5)),U,1)
QUIT
+13 SET D=9999999-$PIECE(+^AUPNVSTR(X,0),".",1)
+14 SET APCHSTXA("DATE",D,X)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 DO WRITEST
+16 ; <CLEANUP>
STROKEX KILL APCHARR,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ,APCHNODE
+1 QUIT
WPSTR ;
+1 KILL ^UTILITY($JOB,"W")
+2 IF '$ORDER(^AUPNVSTR(APCHX,APCHNODE,0))
WRITE !
QUIT
+3 NEW APCHY
+4 SET APCHY=0
+5 SET DIWL=17
SET DIWR=79
FOR
SET APCHY=$ORDER(^AUPNVSTR(APCHX,APCHNODE,APCHY))
IF APCHY'=+APCHY
QUIT
Begin DoDot:1
+6 SET X=^AUPNVSTR(APCHX,APCHNODE,APCHY,0)
DO ^DIWP
+7 QUIT
End DoDot:1
+8 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 WRITE ?17,^UTILITY($JOB,"W",DIWL,Z,0),!
End DoDot:1
+11 KILL DIWL,DIWR,DIWF,Z
+12 KILL ^UTILITY($JOB,"W"),APCHY
+13 QUIT
WRITEST ;
+1 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA("DATE",APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHSTXA("DATE",APCHSIVD,APCHX))
IF APCHX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+4 WRITE ?3,"Arrived at: ",$$GET1^DIQ(9000010.63,APCHX,.01),!
+5 WRITE ?6,"Symptoms: "
+6 ;loop through 14 node and display SYMPTOMS findings
+7 ;.01 concept id ,.02 DESC id | .03,, .0 WITNESSED by
+8 SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNVSTR(APCHX,14,APCHY))
IF APCHY'=+APCHY!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+9 ;X APCHSCKP Q:$D(APCHSQIT)
+10 SET APCHZ=^AUPNVSTR(APCHX,14,APCHY,0)
+11 WRITE ?6,$$CONCPT^AUPNVUTL($PIECE(APCHZ,U,1)),!
+12 SET X=$$DESCPT^AUPNVUTL($PIECE(APCHZ,U,2))_"|"_$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.03)
+13 SET APCHSNRQ=""
SET APCHSTXT=X
SET APCHSICL=6
DO PRTTXT^APCHSUTL
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 WRITE ?6,"Witnessed by: ",$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.07),!
+16 WRITE ?6,"Date/Time Witnessed: ",$$GET1^DIQ(9000010.6314,APCHY_","_APCHX,.08),!
End DoDot:3
+17 ;handedness
+18 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+19 SET APCHY=0
SET APCHZ=""
FOR
SET APCHY=$ORDER(^AUPNVSTR(APCHX,2,APCHY))
IF APCHY'=+APCHY!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+20 IF APCHZ]""
SET APCHZ=APCHZ_"; "
+21 SET APCHZ=APCHZ_$$GET1^DIQ(9000010.632,APCHY_","_APCHX,.019)
End DoDot:3
+22 WRITE ?6,"Handedness: ",APCHZ,!
+23 ;loop through 13 node and display protocols initiated
+24 ;.01 free text ,.02 date/time, .03 entered by
+25 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+26 SET APCHY=$$WT(APCHX)
+27 IF APCHY]""
WRITE ?6,"Weight: ",$PIECE(APCHY,U)," lbs ("_$PIECE(APCHY,U,2),")",!
+28 ;X APCHSCKP Q:$D(APCHSQIT)
+29 ;total score stroke
+30 SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNVSTR(APCHX,15,APCHY))
IF APCHY'=+APCHY!($DATA(APCHQIT))
QUIT
Begin DoDot:3
+31 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+32 WRITE ?6,"Stroke Score: ",$$GET1^DIQ(9000010.6315,APCHY_","_APCHX,.19)," @ ",$$GET1^DIQ(9000010.6315,APCHY_","_APCHX,.02),!
End DoDot:3
+33 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+34 WRITE ?3,"Standing orders/Protocols Initiated",!
+35 SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNVSTR(APCHX,13,APCHY))
IF APCHY'=+APCHY!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+36 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+37 SET APCHZ=^AUPNVSTR(APCHX,13,APCHY,0)
+38 SET X=$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.01)_" "_$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.02)_" by "_$$GET1^DIQ(9000010.6313,APCHY_","_APCHX,.04)
+39 SET APCHSNRQ=""
SET APCHSTXT=X
SET APCHSICL=6
DO PRTTXT^APCHSUTL
End DoDot:3
+40 IF $PIECE(^AUPNVSTR(APCHX,0),U,11)]""
WRITE ?3,"Fibrinolytic therapy started at: ",$$GET1^DIQ(9000010.63,APCHX,.11)," by ",$$GET1^DIQ(9000010.3,APCHX,.13),!
+41 IF $PIECE(^AUPNVSTR(APCHX,0),U,14)]""
Begin DoDot:3
+42 WRITE ?3,"Fibrinolytic Not Started: ",$$GET1^DIQ(9000010.63,APCHX,.14)," by ",$$GET1^DIQ(9000010.63,APCHX,.16),!
+43 WRITE ?3,"Reason Not Started: ",$$GET1^DIQ(9000010.63,APCHX,.17),!
End DoDot:3
End DoDot:2
+44 WRITE !
End DoDot:1
+45 QUIT
WT(V) ;IS THERE A WEIGHT ON THIS DATE?
+1 NEW D,A,B,C,P
+2 SET A=$$VALI^XBDIQ1(9000010.63,V,.03)
+3 IF 'A
QUIT ""
+4 IF '$DATA(^AUPNVSIT(A,0))
QUIT ""
+5 SET D=$PIECE($PIECE(^AUPNVSIT(A,0),U),".")
+6 SET P=$$VALI^XBDIQ1(9000010.63,V,.02)
+7 IF 'P
QUIT ""
+8 SET C=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",D,D,"A")
+9 IF C=""
QUIT ""
+10 QUIT $PIECE(C,U,3)_U_$$VAL^XBDIQ1(9000010.01,$PIECE(C,U,6),1201)
