BEHOENP2 ;MSC/IND/MGH - Summary Report for Selected Encounter ;24-Mar-2016 04:54;du
;;1.1;BEH COMPONENTS;**005003,005004,005005**;Mar 20, 2007
;=================================================================
MEAS(BEHVSIT,DFN,BEHQUIT) ;EP - Find the vital measurements for this visit
S BEHIEN="" F S BEHIEN=$O(^GMR(120.5,"B",BEHVSIT,BEHIEN)) Q:BEHIEN="" D
.Q:$P($G(^AUPNVMSR(BEHIEN,2)),U,1)=1 ;Quit if entered in error
.S BEHTYP=$$GET1^DIQ(9000010.01,BEHIEN,.01,"E")
.S BEH="" S BEH=$O(^BEHOVM(90460.01,"B",BEHTYP,BEH))
.I BEH'="" D
..S VDATA=$G(^BEHOVM(90460.01,BEH,0))
..S DEFAULT=$P(VDATA,U,2)
..I DEFAULT="" S DEFU=""
..I DEFAULT=1 D
...S DEFU=$P(VDATA,U,4)
..I DEFAULT=0 D
...S DEFU=$P(VDATA,U,3)
.S BEHVAL=$$RND($$GET1^DIQ(9000010.01,BEHIEN,.04,"E"))
.S BEHDT=$$GET1^DIQ(9000010.01,BEHIEN,.07,"E")
.S BEHDTI=$$GET1^DIQ(9000010.01,BEHIEN,.07,"I")
.I BEHDT="" D
..S BEHDT=$$GET1^DIQ(9000010.01,BEHIEN,1201,"E")
..S BEHDTI=$$GET1^DIQ(9000010.01,BEHIEN,1201,"I")
.I BEHDT'=OLDBEHDT S BENCNT=0,OLDBEHDT=BEHDT
.S QUALSTR=""
.S MOD=0 F S MOD=$O(^AUPNVMSR(BEHIEN,5,MOD)) Q:'+MOD D
..S QUAL=$G(^AUPNVMSR(BEHIEN,5,MOD,0))
..S QUAL=$P($G(^GMRD(120.52,QUAL,0)),U,1)
..S QUALSTR=QUALSTR_QUAL_","
.S BEHCNT=BEHCNT+1
.S BEHVIT(BEHDTI,BEHCNT)=BEHTYP_U_BEHVAL_" "_DEFU_U_QUALSTR
I $D(BEHVIT) D
.S NAME="VITAL MEASUREMENTS"
.D HDR^BEHOENPV(NAME,BEHCNT)
.W !,"DT/TIME",?25,"TYPE",?40,"VALUE",?55,"MODIFIERS",!
.N I,J
.S I="" F S I=$O(BEHVIT(I)) Q:I="" D
..W !,$$FMTE^XLFDT(I)
..S J="" F S J=$O(BEHVIT(I,J)) Q:J="" D
...W !,?25,$P(BEHVIT(I,J),U,1),?40,$P(BEHVIT(I,J),U,2),?55,$P(BEHVIT(I,J),U,3)
Q
; Write text with word wrap
WRAP(TXT,RM) ;
N LM,WD,X,Y
S RM=$G(RM,IOM),LM=$X,WD=RM-LM
Q:WD<5 ""
F Q:'$L(TXT) D
.I $L(TXT)'>WD W TXT S TXT="" Q
.S X=0,Y=WD
.F S X=$F(TXT," ",X) Q:'X!(X>WD) S Y=X
.W $E(TXT,1,Y-1)
.S TXT=$E(TXT,Y,9999)
.W:$L(TXT) !?LM
Q ""
RND(X) Q $S(X=+X:+$J(X,0,2),1:X)
PROBLST(SNO,FIVE) ; Add item to problem list if not already there
N IEN,PROB,FOUND,NCODE,NUMBER,DATA,ICD,NUM,NUMBER,NEW,SPROB,DEL,LIEN,DATA,MATCH,STAT
S SPROB="",FOUND=0
S NCODE=$P(VAL,U,1)
;If this patient already has this code on his problem list, just quit
S PROB="" F S PROB=$O(^AUPNPROB("APCT",DFN,SNO,PROB)) Q:PROB=""!(FOUND=1) D
.S DEL=$$GET1^DIQ(9000011,PROB,2.02)
.I DEL="" S MATCH=1,SPROB=PROB
I 'SPROB D
.S IEN="+1",OPR=0
.S LIEN=$$GET1^DIQ(9000010,VIEN,.06,"I")
.S NEW=1+$E($O(^AUPNPROB("AA",DFN,LIEN,""),-1),2,99)
.S FDA=$NA(FDA(9000011,IEN_","))
.S @FDA@(.01)=CODE
.S @FDA@(.02)=DFN
.S @FDA@(.03)=$$NOW^XLFDT
.S @FDA@(.05)=NAR
.S @FDA@(.06)=DUZ(2)
.S @FDA@(.07)=NEW
.S @FDA@(.08)=$$NOW^XLFDT
.S STAT=$$CHKSNO(SNO)
.S @FDA@(.12)=STAT
.S @FDA@(.14)=DUZ
.S @FDA@(1.03)=DUZ
.S @FDA@(1.04)=DUZ
.;IHS/MGH/MGH SNOMED fields added
.S @FDA@(80001)=SNO
.S @FDA@(80002)=DESC
.D UPDATE^DIE("","FDA","IEN","ERR")
.I '$D(ERR("DIERR")) D
..S SPROB=IEN(1)
..S DATA=SPROB_U_$G(CIA("UID"))_U_1
..D:DFN BRDCAST^CIANBEVT("PCC."_DFN_".PRB",DATA)
..;Set any extra ICD codes
..D SETICD^BGOPROB1(.RES,SPROB,FIVE,";")
..Q:+RES
Q:'+SPROB ""
I $D(^AUPNPROB(SPROB,14,"B",VIEN)) Q SPROB
N PRIEN,FDA,IEN,ERR
S PRIEN="+1,"_SPROB_","
S FDA(9000011.14,PRIEN,.01)=VIEN
D UPDATE^DIE(,"FDA","IEN","ERR")
Q SPROB
ADDICD(RET,VAL,FIVE,PROB) ;Add any additional ICD codes as POV
N DUP2,SFIVE,X,I,DEL
S DEL=";",PROB=$G(PROB)
S SFIVE=$G(FIVE)
S X=$L(FIVE,DEL)
F I=2:1:X D
.S $P(VAL,U,2)=$P(SFIVE,DEL,I)
.D SETEXTRA(.RET,.VAL)
Q
N NAR,VAL1,SNO,DESC,X,CODE,TXT,FIVE
S DESC=$P(VAL,U,11)
S TXT=$P(VAL,U,10)
S CODE=$P(VAL,U,2)
I $$AICD^BEHOENPC S CODE=$P($$CODEN^ICDEX(CODE,80),"~",1)
E S CODE=+$$CODEN^ICDCODE(CODE,80)
Q:CODE'>0
S $P(VAL,U,4)=$$NARR^BEHOENPC(TXT_"|"_DESC)
S $P(VAL,U,2)=CODE
S $P(VAL,U,6)="S"
D SET^BEHOENPC(.04,4),SET^BEHOENPC(.12,6),SET^BEHOENPC(.08,7),SET^BEHOENPC(1101,9),SET^BEHOENPC(1102,11),SET^BEHOENPC(.16,12)
D STORE^BEHOENPC(.07)
Q
CHKSNO(SNO) ;Check for term coming from pharm ed
N DATA,CHK,GOOD
S GOOD="E"
D GETLST^XPAR(.DATA,"ALL","BEHORXED POV SNOMED LIST")
F CHK=1:1:DATA D
.I SNO=$P($G(DATA(CHK)),U,2) S GOOD="R"
Q GOOD
BEHOENP2 ;MSC/IND/MGH - Summary Report for Selected Encounter ;24-Mar-2016 04:54;du
+1 ;;1.1;BEH COMPONENTS;**005003,005004,005005**;Mar 20, 2007
+2 ;=================================================================
MEAS(BEHVSIT,DFN,BEHQUIT) ;EP - Find the vital measurements for this visit
+1 SET BEHIEN=""
FOR
SET BEHIEN=$ORDER(^GMR(120.5,"B",BEHVSIT,BEHIEN))
IF BEHIEN=""
QUIT
Begin DoDot:1
+2 ;Quit if entered in error
IF $PIECE($GET(^AUPNVMSR(BEHIEN,2)),U,1)=1
QUIT
+3 SET BEHTYP=$$GET1^DIQ(9000010.01,BEHIEN,.01,"E")
+4 SET BEH=""
SET BEH=$ORDER(^BEHOVM(90460.01,"B",BEHTYP,BEH))
+5 IF BEH'=""
Begin DoDot:2
+6 SET VDATA=$GET(^BEHOVM(90460.01,BEH,0))
+7 SET DEFAULT=$PIECE(VDATA,U,2)
+8 IF DEFAULT=""
SET DEFU=""
+9 IF DEFAULT=1
Begin DoDot:3
+10 SET DEFU=$PIECE(VDATA,U,4)
End DoDot:3
+11 IF DEFAULT=0
Begin DoDot:3
+12 SET DEFU=$PIECE(VDATA,U,3)
End DoDot:3
End DoDot:2
+13 SET BEHVAL=$$RND($$GET1^DIQ(9000010.01,BEHIEN,.04,"E"))
+14 SET BEHDT=$$GET1^DIQ(9000010.01,BEHIEN,.07,"E")
+15 SET BEHDTI=$$GET1^DIQ(9000010.01,BEHIEN,.07,"I")
+16 IF BEHDT=""
Begin DoDot:2
+17 SET BEHDT=$$GET1^DIQ(9000010.01,BEHIEN,1201,"E")
+18 SET BEHDTI=$$GET1^DIQ(9000010.01,BEHIEN,1201,"I")
End DoDot:2
+19 IF BEHDT'=OLDBEHDT
SET BENCNT=0
SET OLDBEHDT=BEHDT
+20 SET QUALSTR=""
+21 SET MOD=0
FOR
SET MOD=$ORDER(^AUPNVMSR(BEHIEN,5,MOD))
IF '+MOD
QUIT
Begin DoDot:2
+22 SET QUAL=$GET(^AUPNVMSR(BEHIEN,5,MOD,0))
+23 SET QUAL=$PIECE($GET(^GMRD(120.52,QUAL,0)),U,1)
+24 SET QUALSTR=QUALSTR_QUAL_","
End DoDot:2
+25 SET BEHCNT=BEHCNT+1
+26 SET BEHVIT(BEHDTI,BEHCNT)=BEHTYP_U_BEHVAL_" "_DEFU_U_QUALSTR
End DoDot:1
+27 IF $DATA(BEHVIT)
Begin DoDot:1
+28 SET NAME="VITAL MEASUREMENTS"
+29 DO HDR^BEHOENPV(NAME,BEHCNT)
+30 WRITE !,"DT/TIME",?25,"TYPE",?40,"VALUE",?55,"MODIFIERS",!
+31 NEW I,J
+32 SET I=""
FOR
SET I=$ORDER(BEHVIT(I))
IF I=""
QUIT
Begin DoDot:2
+33 WRITE !,$$FMTE^XLFDT(I)
+34 SET J=""
FOR
SET J=$ORDER(BEHVIT(I,J))
IF J=""
QUIT
Begin DoDot:3
+35 WRITE !,?25,$PIECE(BEHVIT(I,J),U,1),?40,$PIECE(BEHVIT(I,J),U,2),?55,$PIECE(BEHVIT(I,J),U,3)
End DoDot:3
End DoDot:2
End DoDot:1
+36 QUIT
+37 ; Write text with word wrap
WRAP(TXT,RM) ;
+1 NEW LM,WD,X,Y
+2 SET RM=$GET(RM,IOM)
SET LM=$X
SET WD=RM-LM
+3 IF WD<5
QUIT ""
+4 FOR
IF '$LENGTH(TXT)
QUIT
Begin DoDot:1
+5 IF $LENGTH(TXT)'>WD
WRITE TXT
SET TXT=""
QUIT
+6 SET X=0
SET Y=WD
+7 FOR
SET X=$FIND(TXT," ",X)
IF 'X!(X>WD)
QUIT
SET Y=X
+8 WRITE $EXTRACT(TXT,1,Y-1)
+9 SET TXT=$EXTRACT(TXT,Y,9999)
+10 IF $LENGTH(TXT)
WRITE !?LM
End DoDot:1
+11 QUIT ""
RND(X) QUIT $SELECT(X=+X:+$JUSTIFY(X,0,2),1:X)
PROBLST(SNO,FIVE) ; Add item to problem list if not already there
+1 NEW IEN,PROB,FOUND,NCODE,NUMBER,DATA,ICD,NUM,NUMBER,NEW,SPROB,DEL,LIEN,DATA,MATCH,STAT
+2 SET SPROB=""
SET FOUND=0
+3 SET NCODE=$PIECE(VAL,U,1)
+4 ;If this patient already has this code on his problem list, just quit
+5 SET PROB=""
FOR
SET PROB=$ORDER(^AUPNPROB("APCT",DFN,SNO,PROB))
IF PROB=""!(FOUND=1)
QUIT
Begin DoDot:1
+6 SET DEL=$$GET1^DIQ(9000011,PROB,2.02)
+7 IF DEL=""
SET MATCH=1
SET SPROB=PROB
End DoDot:1
+8 IF 'SPROB
Begin DoDot:1
+9 SET IEN="+1"
SET OPR=0
+10 SET LIEN=$$GET1^DIQ(9000010,VIEN,.06,"I")
+11 SET NEW=1+$EXTRACT($ORDER(^AUPNPROB("AA",DFN,LIEN,""),-1),2,99)
+12 SET FDA=$NAME(FDA(9000011,IEN_","))
+13 SET @FDA@(.01)=CODE
+14 SET @FDA@(.02)=DFN
+15 SET @FDA@(.03)=$$NOW^XLFDT
+16 SET @FDA@(.05)=NAR
+17 SET @FDA@(.06)=DUZ(2)
+18 SET @FDA@(.07)=NEW
+19 SET @FDA@(.08)=$$NOW^XLFDT
+20 SET STAT=$$CHKSNO(SNO)
+21 SET @FDA@(.12)=STAT
+22 SET @FDA@(.14)=DUZ
+23 SET @FDA@(1.03)=DUZ
+24 SET @FDA@(1.04)=DUZ
+25 ;IHS/MGH/MGH SNOMED fields added
+26 SET @FDA@(80001)=SNO
+27 SET @FDA@(80002)=DESC
+28 DO UPDATE^DIE("","FDA","IEN","ERR")
+29 IF '$DATA(ERR("DIERR"))
Begin DoDot:2
+30 SET SPROB=IEN(1)
+31 SET DATA=SPROB_U_$GET(CIA("UID"))_U_1
+32 IF DFN
DO BRDCAST^CIANBEVT("PCC."_DFN_".PRB",DATA)
+33 ;Set any extra ICD codes
+34 DO SETICD^BGOPROB1(.RES,SPROB,FIVE,";")
+35 IF +RES
QUIT
End DoDot:2
End DoDot:1
+36 IF '+SPROB
QUIT ""
+37 IF $DATA(^AUPNPROB(SPROB,14,"B",VIEN))
QUIT SPROB
+38 NEW PRIEN,FDA,IEN,ERR
+39 SET PRIEN="+1,"_SPROB_","
+40 SET FDA(9000011.14,PRIEN,.01)=VIEN
+41 DO UPDATE^DIE(,"FDA","IEN","ERR")
+42 QUIT SPROB
ADDICD(RET,VAL,FIVE,PROB) ;Add any additional ICD codes as POV
+1 NEW DUP2,SFIVE,X,I,DEL
+2 SET DEL=";"
SET PROB=$GET(PROB)
+3 SET SFIVE=$GET(FIVE)
+4 SET X=$LENGTH(FIVE,DEL)
+5 FOR I=2:1:X
Begin DoDot:1
+6 SET $PIECE(VAL,U,2)=$PIECE(SFIVE,DEL,I)
+7 DO SETEXTRA(.RET,.VAL)
End DoDot:1
+8 QUIT
+1 NEW NAR,VAL1,SNO,DESC,X,CODE,TXT,FIVE
+2 SET DESC=$PIECE(VAL,U,11)
+3 SET TXT=$PIECE(VAL,U,10)
+4 SET CODE=$PIECE(VAL,U,2)
+5 IF $$AICD^BEHOENPC
SET CODE=$PIECE($$CODEN^ICDEX(CODE,80),"~",1)
+6 IF '$TEST
SET CODE=+$$CODEN^ICDCODE(CODE,80)
+7 IF CODE'>0
QUIT
+8 SET $PIECE(VAL,U,4)=$$NARR^BEHOENPC(TXT_"|"_DESC)
+9 SET $PIECE(VAL,U,2)=CODE
+10 SET $PIECE(VAL,U,6)="S"
+11 DO SET^BEHOENPC(.04,4)
DO SET^BEHOENPC(.12,6)
DO SET^BEHOENPC(.08,7)
DO SET^BEHOENPC(1101,9)
DO SET^BEHOENPC(1102,11)
DO SET^BEHOENPC(.16,12)
+12 DO STORE^BEHOENPC(.07)
+13 QUIT
CHKSNO(SNO) ;Check for term coming from pharm ed
+1 NEW DATA,CHK,GOOD
+2 SET GOOD="E"
+3 DO GETLST^XPAR(.DATA,"ALL","BEHORXED POV SNOMED LIST")
+4 FOR CHK=1:1:DATA
Begin DoDot:1
+5 IF SNO=$PIECE($GET(DATA(CHK)),U,2)
SET GOOD="R"
End DoDot:1
+6 QUIT GOOD
