BEHOENP2.m

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

SETEXTRA(RET,VAL) ;add in extra ICD codes

 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 

SETEXTRA(RET,VAL) ;add in extra ICD codes

 +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