BEHOCIR.m

BEHOCIR ;MSC/IND/MGH - CCD calls ;03-Dec-2013 13:37;du

 ;;1.1;BEH COMPONENTS;**066001**;March 12, 2008;Build 1

 ;=================================================================

 ;Set entry into the CCD

 ;The date/time and user will be associated with all the items in the list

 ;Input DATA=IEN of reconciliation entry [1]^ DFN [2] ^ BY [3] ^ IMAGE [4] ^ Source [5]^ Allergy date/time [6] ^ Problem dt/time [7] ^ Medication dt/time [8]

 ;      List(n)=Type [1] ^ Item [2]

SET(RET,DATA,LIST) ;EP

 N BY,NEW,IEN,IENS,FDA,FNUM,BY,SRC,AREC,PREC,MREC,CNT,WHEN

 S RET="",NEW=""

 S IEN=""

 D TOP(.RET,DATA)

 Q:+RET=-1

 S CNT="" F  S CNT=$O(LIST(CNT)) Q:CNT=""  D

 .D ITEM(IEN,BY)

 ;Update the dates of the pieces

 S FNUM=90461.63

 S IENS=IEN_","

 S FDA=$NA(FDA(FNUM,IENS))

 S @FDA@(.07)=AREC

 S @FDA@(.08)=PREC

 S @FDA@(.09)=MREC

 D FILE^DIE("E","FDA","ERR")

 I $D(ERR("DIERR")) S RET=ERR("DIERR")

 I (AREC'="")&(PREC'="")&(MREC'="") D FINISH(IEN)

 S RET=IEN

 Q

TOP(RET,DATA) ;Get the top entry data and store it

 N FNUM,FDA,IENS,ERR,IEN2,DFN,IMG

 S IEN=$P(DATA,U,1)

 I IEN="" S NEW=1

 S DFN=$P(DATA,U,2)

 I DFN="" S RET="-1^No patient identified" Q

 S BY=$P(DATA,U,3)

 I BY="" S BY=$$GET1^DIQ(200,DUZ,.01)

 S IMG=$P(DATA,U,4)

 ;I IMG="" S RET="-1^No CCDA identified" Q

 S SRC=$P(DATA,U,5)

 S AREC=$P(DATA,U,6)

 S PREC=$P(DATA,U,7)

 S MREC=$P(DATA,U,8)

 S FNUM=90461.63

 S IENS=$S('NEW:IEN_",",1:"+1,")

 S FDA=$NA(FDA(FNUM,IENS))

 S:NEW @FDA@(.01)=$$NOW^XLFDT

 S:NEW @FDA@(.02)=DFN

 S @FDA@(.03)=SRC

 S @FDA@(.05)=BY

 S @FDA@(1.1)=IMG

 I NEW D

 .D UPDATE^DIE("","FDA","IEN2","ERR")

 .I $D(ERR) S RET="-1^Unable to add reconcillation data"

 .E  S IEN=IEN2(1)

 E  D

 .D FILE^DIE("E","FDA","ERR")

 .I $D(ERR("DIERR")) S RET=ERR("DIERR")

 Q

ITEM(IEN,BY) ;Store each item

 N FDA,DIERR,TYPE,AIEN,IENS,ERR,TIEN

 Q:IEN=""

 S TYPE=$P(LIST(CNT),U,1)

 S TIEN=$P(LIST(CNT),U,2)

 S AIEN="+1,"_IEN_","

 S FDA=$NA(FDA(90461.632,AIEN))

 S @FDA@(.01)=$S(TYPE="A":AREC,TYPE="CA":AREC,TYPE="P":PREC,TYPE="CP":PREC,1:MREC)

 S @FDA@(.02)=DUZ

 S @FDA@(.03)=TYPE

 I TYPE["C" S @FDA@(.05)=TIEN

 E  S @FDA@(.04)=+TIEN

 I AREC'="" S @FDA@(.07)=AREC

 I PREC'="" S @FDA@(.08)=PREC

 I MREC'="" S @FDA@(.09)=MREC

 D UPDATE^DIE("","FDA","IENS","ERR")

 S:$G(DIERR) RET=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)

 Q

FINISH(IEN) ;Mark it reconciled

 N FDA,ERR

 S FDA=$NA(FDA(90461.63,IEN))

 S @FDA@(.04)=1

 D UPDATE^DIE("","FDA","","ERR")

 Q

 ;Get latest reconcilations for a CCDA

 ;Input=Image IEN

 ;Ouput=Alg date[1] ^ Prob date [2] ^ med date[3] ^ NEW ien [4]

GETCIR(RET,IMAGE) ;Get the reconciliations for a CCDS

 N INVA,IEN,FIELD,IDATE,ADATE,PDATE,MDATE,NEW,I

 S (ADATE,PDATE,MDATE,NEW)=""

 S RET=""

 F I="AE","AF","AG" D

 .S INVA="" S INVA=$O(^BEHOCIR(I,IMAGE,INVA)) Q:INVA=""  D

 ..S IEN="" S IEN=$O(^BEHOCIR(I,IMAGE,INVA,IEN)) Q:IEN=""  D

 ...S FIELD=$S(I="AE":.07,I="AF":.08,I="AG":.09)

 ...S IDATE=$$GET1^DIQ(90461.63,IEN,FIELD)

 ...I I="AE" S ADATE=IDATE

 ...I I="AF" S PDATE=IDATE

 ...I I="AG" S MDATE=IDATE

 I ADATE=""&(PDATE="")&(MDATE="") D

 .S NEW="" S NEW=$O(^BEHOCIR("D",IMAGE,NEW))

 S RET=ADATE_U_PDATE_U_MDATE_U_NEW

 Q

GETTXT(RET,SNOMED) ;Return text of SNOMED CT

 N IN,X,TXT,CODE,DESC

 S RET=""

 S IN=SNOMED_"^^^1"

 S X=$$CONC^BSTSAPI(IN)

 S TXT=$P(X,U,4)

 S DESC=$P(X,U,3)

 S RET=TXT_U_DESC

 Q

GETNUM(RET,DFN) ;Return number of CCDAs for a pt

 N INVDT,IEN,IMAGE,AREC,PREC,MREC,DCNT,NCNT,ARRAY,DATA,ITYPE

 S DCNT=0,NCNT=0

 S INVDT=""

 F  S INVDT=$O(^BEHOCIR("AA",DFN,INVDT)) Q:INVDT=""  D

 .S IEN="" F  S IEN=$O(^BEHOCIR("AA",DFN,INVDT,IEN)) Q:IEN=""  D

 ..S IMAGE=$P($G(^BEHOCIR(IEN,1)),U,1)

 ..Q:IMAGE=""

 ..Q:$P($G(^MAG(2005,IMAGE,100)),U,5)'=""

 ..S ARRAY(IMAGE)=""

 S IMG="" F  S IMG=$O(ARRAY(IMG)) Q:IMG=""  D

 .S DATA=""

 .S DCNT=DCNT+1

 .D GETCIR(.DATA,IMG)

 .I $P(DATA,U,1)'=""&($P(DATA,U,2)'="")&($P(DATA,U,3)'="") S NCNT=NCNT+1

 S RET=DCNT_U_NCNT

 Q

TMPGBL() ;EP

 K ^TMP("BEHCIR",$J) Q $NA(^($J))

BEHOCIR   ;MSC/IND/MGH - CCD calls ;03-Dec-2013 13:37;du

 +1       ;;1.1;BEH COMPONENTS;**066001**;March 12, 2008;Build 1

 +2       ;=================================================================

 +3       ;Set entry into the CCD

 +4       ;The date/time and user will be associated with all the items in the list

 +5       ;Input DATA=IEN of reconciliation entry [1]^ DFN [2] ^ BY [3] ^ IMAGE [4] ^ Source [5]^ Allergy date/time [6] ^ Problem dt/time [7] ^ Medication dt/time [8]

 +6       ;      List(n)=Type [1] ^ Item [2]

SET(RET,DATA,LIST) ;EP

 +1        NEW BY,NEW,IEN,IENS,FDA,FNUM,BY,SRC,AREC,PREC,MREC,CNT,WHEN

 +2        SET RET=""

           SET NEW=""

 +3        SET IEN=""

 +4        DO TOP(.RET,DATA)

 +5        IF +RET=-1

               QUIT 

 +6        SET CNT=""

           FOR 

               SET CNT=$ORDER(LIST(CNT))

               IF CNT=""

                   QUIT 

               Begin DoDot:1

 +7                DO ITEM(IEN,BY)

               End DoDot:1

 +8       ;Update the dates of the pieces

 +9        SET FNUM=90461.63

 +10       SET IENS=IEN_","

 +11       SET FDA=$NAME(FDA(FNUM,IENS))

 +12       SET @FDA@(.07)=AREC

 +13       SET @FDA@(.08)=PREC

 +14       SET @FDA@(.09)=MREC

 +15       DO FILE^DIE("E","FDA","ERR")

 +16       IF $DATA(ERR("DIERR"))

               SET RET=ERR("DIERR")

 +17       IF (AREC'="")&(PREC'="")&(MREC'="")

               DO FINISH(IEN)

 +18       SET RET=IEN

 +19       QUIT 

TOP(RET,DATA) ;Get the top entry data and store it

 +1        NEW FNUM,FDA,IENS,ERR,IEN2,DFN,IMG

 +2        SET IEN=$PIECE(DATA,U,1)

 +3        IF IEN=""

               SET NEW=1

 +4        SET DFN=$PIECE(DATA,U,2)

 +5        IF DFN=""

               SET RET="-1^No patient identified"

               QUIT 

 +6        SET BY=$PIECE(DATA,U,3)

 +7        IF BY=""

               SET BY=$$GET1^DIQ(200,DUZ,.01)

 +8        SET IMG=$PIECE(DATA,U,4)

 +9       ;I IMG="" S RET="-1^No CCDA identified" Q

 +10       SET SRC=$PIECE(DATA,U,5)

 +11       SET AREC=$PIECE(DATA,U,6)

 +12       SET PREC=$PIECE(DATA,U,7)

 +13       SET MREC=$PIECE(DATA,U,8)

 +14       SET FNUM=90461.63

 +15       SET IENS=$SELECT('NEW:IEN_",",1:"+1,")

 +16       SET FDA=$NAME(FDA(FNUM,IENS))

 +17       IF NEW

               SET @FDA@(.01)=$$NOW^XLFDT

 +18       IF NEW

               SET @FDA@(.02)=DFN

 +19       SET @FDA@(.03)=SRC

 +20       SET @FDA@(.05)=BY

 +21       SET @FDA@(1.1)=IMG

 +22       IF NEW

               Begin DoDot:1

 +23               DO UPDATE^DIE("","FDA","IEN2","ERR")

 +24               IF $DATA(ERR)

                       SET RET="-1^Unable to add reconcillation data"

 +25              IF '$TEST

                       SET IEN=IEN2(1)

               End DoDot:1

 +26      IF '$TEST

               Begin DoDot:1

 +27               DO FILE^DIE("E","FDA","ERR")

 +28               IF $DATA(ERR("DIERR"))

                       SET RET=ERR("DIERR")

               End DoDot:1

 +29       QUIT 

ITEM(IEN,BY) ;Store each item

 +1        NEW FDA,DIERR,TYPE,AIEN,IENS,ERR,TIEN

 +2        IF IEN=""

               QUIT 

 +3        SET TYPE=$PIECE(LIST(CNT),U,1)

 +4        SET TIEN=$PIECE(LIST(CNT),U,2)

 +5        SET AIEN="+1,"_IEN_","

 +6        SET FDA=$NAME(FDA(90461.632,AIEN))

 +7        SET @FDA@(.01)=$SELECT(TYPE="A":AREC,TYPE="CA":AREC,TYPE="P":PREC,TYPE="CP":PREC,1:MREC)

 +8        SET @FDA@(.02)=DUZ

 +9        SET @FDA@(.03)=TYPE

 +10       IF TYPE["C"

               SET @FDA@(.05)=TIEN

 +11      IF '$TEST

               SET @FDA@(.04)=+TIEN

 +12       IF AREC'=""

               SET @FDA@(.07)=AREC

 +13       IF PREC'=""

               SET @FDA@(.08)=PREC

 +14       IF MREC'=""

               SET @FDA@(.09)=MREC

 +15       DO UPDATE^DIE("","FDA","IENS","ERR")

 +16       IF $GET(DIERR)

               SET RET=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)

 +17       QUIT 

FINISH(IEN) ;Mark it reconciled

 +1        NEW FDA,ERR

 +2        SET FDA=$NAME(FDA(90461.63,IEN))

 +3        SET @FDA@(.04)=1

 +4        DO UPDATE^DIE("","FDA","","ERR")

 +5        QUIT 

 +6       ;Get latest reconcilations for a CCDA

 +7       ;Input=Image IEN

 +8       ;Ouput=Alg date[1] ^ Prob date [2] ^ med date[3] ^ NEW ien [4]

GETCIR(RET,IMAGE) ;Get the reconciliations for a CCDS

 +1        NEW INVA,IEN,FIELD,IDATE,ADATE,PDATE,MDATE,NEW,I

 +2        SET (ADATE,PDATE,MDATE,NEW)=""

 +3        SET RET=""

 +4        FOR I="AE","AF","AG"

               Begin DoDot:1

 +5                SET INVA=""

                   SET INVA=$ORDER(^BEHOCIR(I,IMAGE,INVA))

                   IF INVA=""

                       QUIT 

                   Begin DoDot:2

 +6                    SET IEN=""

                       SET IEN=$ORDER(^BEHOCIR(I,IMAGE,INVA,IEN))

                       IF IEN=""

                           QUIT 

                       Begin DoDot:3

 +7                        SET FIELD=$SELECT(I="AE":.07,I="AF":.08,I="AG":.09)

 +8                        SET IDATE=$$GET1^DIQ(90461.63,IEN,FIELD)

 +9                        IF I="AE"

                               SET ADATE=IDATE

 +10                       IF I="AF"

                               SET PDATE=IDATE

 +11                       IF I="AG"

                               SET MDATE=IDATE

                       End DoDot:3

                   End DoDot:2

               End DoDot:1

 +12       IF ADATE=""&(PDATE="")&(MDATE="")

               Begin DoDot:1

 +13               SET NEW=""

                   SET NEW=$ORDER(^BEHOCIR("D",IMAGE,NEW))

               End DoDot:1

 +14       SET RET=ADATE_U_PDATE_U_MDATE_U_NEW

 +15       QUIT 

GETTXT(RET,SNOMED) ;Return text of SNOMED CT

 +1        NEW IN,X,TXT,CODE,DESC

 +2        SET RET=""

 +3        SET IN=SNOMED_"^^^1"

 +4        SET X=$$CONC^BSTSAPI(IN)

 +5        SET TXT=$PIECE(X,U,4)

 +6        SET DESC=$PIECE(X,U,3)

 +7        SET RET=TXT_U_DESC

 +8        QUIT 

GETNUM(RET,DFN) ;Return number of CCDAs for a pt

 +1        NEW INVDT,IEN,IMAGE,AREC,PREC,MREC,DCNT,NCNT,ARRAY,DATA,ITYPE

 +2        SET DCNT=0

           SET NCNT=0

 +3        SET INVDT=""

 +4        FOR 

               SET INVDT=$ORDER(^BEHOCIR("AA",DFN,INVDT))

               IF INVDT=""

                   QUIT 

               Begin DoDot:1

 +5                SET IEN=""

                   FOR 

                       SET IEN=$ORDER(^BEHOCIR("AA",DFN,INVDT,IEN))

                       IF IEN=""

                           QUIT 

                       Begin DoDot:2

 +6                        SET IMAGE=$PIECE($GET(^BEHOCIR(IEN,1)),U,1)

 +7                        IF IMAGE=""

                               QUIT 

 +8                        IF $PIECE($GET(^MAG(2005,IMAGE,100)),U,5)'=""

                               QUIT 

 +9                        SET ARRAY(IMAGE)=""

                       End DoDot:2

               End DoDot:1

 +10       SET IMG=""

           FOR 

               SET IMG=$ORDER(ARRAY(IMG))

               IF IMG=""

                   QUIT 

               Begin DoDot:1

 +11               SET DATA=""

 +12               SET DCNT=DCNT+1

 +13               DO GETCIR(.DATA,IMG)

 +14               IF $PIECE(DATA,U,1)'=""&($PIECE(DATA,U,2)'="")&($PIECE(DATA,U,3)'="")

                       SET NCNT=NCNT+1

               End DoDot:1

 +15       SET RET=DCNT_U_NCNT

 +16       QUIT 

TMPGBL()  ;EP

 +1        KILL ^TMP("BEHCIR",$JOB)

           QUIT $NAME(^($JOB))