BHLBCH1.m

BHLBCH1 ; IHS/TUCSON/DCP -HL7 ORU Message Processor (continued) ; 

 ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997

 ;

 ; This routine is a continuation of BHLBCH.

 ; It is not independently callable.

 ;

START ; ENTRY POINT from BHLBCH

 ;

 D INIT

 I BHLQUIT D EOJ Q

 D CREATE ;create record with FILE^DICN

 I BHLQUIT D EOJ Q

 D EDIT

 I BHLQUIT D EOJ Q

 D @(BHLTYPE)

 I BHLQUIT D EOJ Q

 D PCCLINK

 D EOJ

 Q

 ;

EOJ ; ENTRY POINT from BHLBCH - KILL VARS AND EXIT

 ;

 I BHLQUIT,BHLR D

 .;delete povs

 .S BHLX=0 F  S BHLX=$O(BHLTPOV(BHLX)) Q:BHLX'=+BHLX  S DA=BHLX,DIK="^BCHRPROB(" D ^DIK

 .S DA=BHLR,DIK="^BCHR(" D ^DIK K DA,DIK

 K BHLBCH,BHLDATA,BHLDUZ2,BHLE,BHLFDA,BHLFIELD,BHLFILE,BHLI,BHLID,BHLITEM,BHLJ,BHLMTYP,BHLN,BHLPIECE,BHLPOV,BHLQUIT,BHLR,BHLRES,BHLSEG,BHLSRV,BHLT,BHLTIEN,BHLTPOV,BHLTYPE,BHLVALUE,BHLX

 K C,D0,DA,DD,DI,DIADD,DIC,DIE,DIG,DIH,DIK,DIQUIET,DIU,DIV,DIW,DIX,DIY,DK,DL,DLAYGO,DO,DQ,DR,F,I,X,U

 K C,IEN,SEX,DOB,F,X,Y

 D KILL^AUPNPAT

 K X,Y,I

 Q

INIT ;

 K HLERR,APCDALVR,IEN

 ;check to be sure that all required pieces of data are present

 ;if not, set error and quit

 S (BHLR,BHLQUIT)=0

 S X=$G(BHLBCH("TRANS")) I X="" S HLERR="TRANSACTION INFORMATION MISSING",BHLQUIT=1 Q

 S BHLTYPE=$P(BHLBCH("TRANS"),U) I BHLTYPE="" S HLERR="TRANSACTION TYPE MISSING",BHLQUIT=1 Q

 S BHLID=$P(BHLBCH("TRANS"),U,2) I BHLID="" S HLERR="TRANSACTION UNIQUE ID MISSING",BHLQUIT=1 Q

 S BHLID=$P(BHLBCH("TRANS"),U,3)_BHLID

 D CHK^DIE(90002,.21,"E",BHLID,.BHLRES) I BHLRES="^" S HLERR="UNIQUE ID FAILED INPUT TRANSFORM",BHLQUIT=1 Q

 I $G(BHLBCH("REC"))="" S HLERR="NO RECORD INFORMATION" S BHLQUIT=1 Q  ;must have a minimum of the record node to continue

 I '$O(BHLBCH("POV",0)) S BHLQUIT=1 S HLERR="NO POV PASSED" Q  ;must have at least 1 pov to continue

 ;date,program,chr,prob code,svc code,svc min,act loc are all required to continue

 F X=1:1:4 S Y=$P(BHLBCH("REC"),U,X) I Y="" S HLERR=$P("DATE^PROGRAM^CHR^ACTLOC",U,X)_" REQUIRED ELEMENT MISSING" S BHLQUIT=1 Q

 ;chk pov

 S X=$O(BHLBCH("POV",0)) I 'X S HLERR="POV MISSING",BHLQUIT=1 Q

 S Y=BHLBCH("POV",X) F I=1:1:3 I $P(Y,U,I)="" S HLERR=$P("HLTH PROB CODE^SVC CODE^SVC MINS",U,I)_" REQUIRED ELEMENT MISSING",BHLQUIT=1 Q

 Q

PCCLINK ;

 S BCHEV("TYPE")="A" ;add,edit or delete

 S BCHR=BHLR

 D PROTOCOL^BCHUADD1

 K BCHEV,BCHR

 Q

A ;

 D A^BHLBCH2

 Q

M ;edit - delete original and do add

 D E^BHLBCH2

 Q

FMKILL ;

 K DIE,DIC,DA,DR,DLAYGO,DIADD,DIU,DIY,DIX,DIV,DIW,DD,D0,DO,DI,DK,DIG,DIH,DL,DQ

 Q

EDIT ;edit all passed data, check against input tx

 ;edit record info against input transform

 S BHLT="REC" D CHECK

 Q:BHLQUIT

 S BHLT="POV" S BHLI=0 F  S BHLI=$O(BHLBCH("POV",BHLI)) Q:BHLI=""!(BHLQUIT)  D CHECK

 Q:BHLQUIT

 I $P(BHLBCH("REC"),U,4)="HC",$P(BHLBCH("REC"),U,12)="" S HLERR="IF ACT LOCATION IS HOSP MUST BE CLINIC NAME",BHLQUIT=1 Q

DEM ;

 I $D(BHLBCH("DEMO")) D

 .F I=3:1:7 S X=$P(BHLBCH("DEMO"),U,I) I X["--" S $P(BHLBCH("DEMO"),U,I)=""

 .S BHLT="DEMO" D CHECK

 Q:BHLQUIT

ETESTS ;edit tests and measurements

 S BHLFILE=90002

 I $D(BHLBCH("MSR")) S BHLN=0 F  S BHLN=$O(BHLBCH("MSR",BHLN)) Q:BHLN'=+BHLN!(BHLQUIT)  S BHLMTYP=$P(BHLBCH("MSR",BHLN),U),BHLVALUE=$P(BHLBCH("MSR",BHLN),U,2) D

 .Q:BHLVALUE=""

 .I BHLMTYP="VU"!(BHLMTYP="VC") D

 ..S X=$P(BHLBCH("MSR",BHLN),U,2)

 ..S BHLVALUE=$P($P(BHLVALUE,"~"),"/",2)_"/"_$P($P(BHLVALUE,"~",2),"/",2),$P(BHLBCH("MSR",BHLN),U,2)=BHLVALUE

 .S BHLTIEN=$O(^BCHTMT("B",BHLMTYP,0)) I BHLTIEN="" S BHLQUIT=1,HLERR="MEASUREMENT TYPE NOT FOUND IN TABLE" Q

 .S BHLFIELD=$P(^BCHTMT(BHLTIEN,0),U,3) I BHLFIELD="" Q

 .K Y,BHLRES S DIQUIET=1 D CHK^DIE(BHLFILE,BHLFIELD,"E",BHLVALUE,.BHLRES)

 .I BHLRES="^" S BHLQUIT=1,HLERR=BHLMTYP_" FAILED INPUT TRANSFORM EDIT" Q

 .S BHLFDA(BHLFILE,BHLR_",",BHLFIELD)=BHLRES

 .Q

 Q

CHECK ;

 S BHLFILE=$P($T(@BHLT),";;",2) F BHLJ=1:1 S BHLX=$T(@BHLT+BHLJ),BHLPIECE=$P(BHLX,";;",2) Q:BHLPIECE="QUIT"!(BHLPIECE="")!(BHLQUIT)  D

 .K BHLRES S BHLITEM=$P(BHLX,";;",3),BHLFIELD=$P(BHLX,";;",4),BHLE=$P(BHLX,";;",5)

 .S:BHLT="POV" X=BHLBCH(BHLT,BHLI) S:BHLT'="POV" X=BHLBCH(BHLT) S X=$P(X,U,BHLPIECE)

 .Q:X=""

 .I BHLE]"" D  Q

 ..X BHLE I '$D(X) S HLERR=BHLITEM_" FAILED INPUT TX EDIT",BHLQUIT=1 Q

 ..I BHLFILE=90002 S BHLFDA(BHLFILE,BHLR_",",BHLFIELD)=X

 .K Y,BHLRES S DIQUIET=1 D CHK^DIE(BHLFILE,BHLFIELD,"E",X,.BHLRES)

 .I BHLRES="^" S BHLQUIT=1,HLERR=BHLITEM_" FAILED INPUT TRANSFORM EDIT" Q

 .I BHLFILE=90002 S BHLFDA(BHLFILE,BHLR_",",BHLFIELD)=BHLRES

 .Q

 Q

 ;

CREATE ;create record in CHR RECORD using FILE^DICN

 S BHLR=$O(^BCHR("CUI",BHLID,0)) I BHLR S BHLTYPE="M" Q

 D FMKILL^BHLBCH2

 S DIC="^BCHR(",DIC(0)="L",X=$P($P(BHLBCH("REC"),U),"@"),%DT="T" D ^%DT S X=Y,DLAYGO=90002,DIC("DR")=".16////"_DUZ_";.17////"_DT_";.22////"_DT_";.26////R" K DD,DO D FILE^DICN

 I Y=-1 S HLERR="CREATING CHR RECORD ENTRY FAILED",BHLQUIT=1 Q

 S BHLR=+Y

 Q

REC ;;90002

 ;;1;;DATE;;.01

 ;;2;;PROGRAM;;.02;;

 ;;3;;CHR;;.03;;

 ;;4;;ACT LOC;;.06;;

 ;;5;;REFERRED TO;;.07;;

 ;;6;;REFERRED BY;;.08;;

 ;;7;;EVALUATION;;.09;;

 ;;8;;TRAVEL TIME;;.11;;

 ;;9;;# SERVED;;.12;;

 ;;10;;INSURER;;2102;;

 ;;11;;PURP REFERRAL;;2101;;

 ;;12;;LOC OF ENCOUNTER;;.05;;

 ;;QUIT

POV ;;90002.01

 ;;1;;HLTH PROB CODE;;.01;;S Y=$O(^BCHTPROB("C",X,0)) K:'Y X I Y S X="`"_Y

 ;;2;;SVC CODE;;.04;;S Y=$O(^BCHTSERV("D",X,0)) K:'Y X I Y S X="`"_X

 ;;3;;SVC MINS;;.05;;

 ;;4;;NARRATIVE;;.06;;X $P(^DD(9999999.27,.01,0),U,5,99)

 ;;5;;SUBSTANCE RELATED;;.07;;

 ;;QUIT

DEMO ;;90002

 ;;1;;PATIENT NAME;;1101;;

 ;;2;;DATE OF BIRTH;;1102;;

 ;;3;;SEX;;1103;;

 ;;4;;SSN;;1104;;

 ;;5;;TRIBE;;1105;;

 ;;6;;COMMUNITY OF RESIDENCE;;1106;;S Y=$O(^AUTTCOM("C",X,0)) K:'Y X I Y S X=Y

 ;;7;;CHART NUMBER;;1111;;

 ;;8;;CHART FACILITY;;1109;;

 ;;9;;TEMP RESIDENCE;;1108;;

 ;;QUIT

BHLBCH1   ; IHS/TUCSON/DCP -HL7 ORU Message Processor (continued) ; 

 +1       ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997

 +2       ;

 +3       ; This routine is a continuation of BHLBCH.

 +4       ; It is not independently callable.

 +5       ;

START     ; ENTRY POINT from BHLBCH

 +1       ;

 +2        DO INIT

 +3        IF BHLQUIT

               DO EOJ

               QUIT 

 +4       ;create record with FILE^DICN

           DO CREATE

 +5        IF BHLQUIT

               DO EOJ

               QUIT 

 +6        DO EDIT

 +7        IF BHLQUIT

               DO EOJ

               QUIT 

 +8        DO @(BHLTYPE)

 +9        IF BHLQUIT

               DO EOJ

               QUIT 

 +10       DO PCCLINK

 +11       DO EOJ

 +12       QUIT 

 +13      ;

EOJ       ; ENTRY POINT from BHLBCH - KILL VARS AND EXIT

 +1       ;

 +2        IF BHLQUIT

               IF BHLR

                   Begin DoDot:1

 +3       ;delete povs

 +4                    SET BHLX=0

                       FOR 

                           SET BHLX=$ORDER(BHLTPOV(BHLX))

                           IF BHLX'=+BHLX

                               QUIT 

                           SET DA=BHLX

                           SET DIK="^BCHRPROB("

                           DO ^DIK

 +5                    SET DA=BHLR

                       SET DIK="^BCHR("

                       DO ^DIK

                       KILL DA,DIK

                   End DoDot:1

 +6        KILL BHLBCH,BHLDATA,BHLDUZ2,BHLE,BHLFDA,BHLFIELD,BHLFILE,BHLI,BHLID,BHLITEM,BHLJ,BHLMTYP,BHLN,BHLPIECE,BHLPOV,BHLQUIT,BHLR,BHLRES,BHLSEG,BHLSRV,BHLT,BHLTIEN,BHLTPOV,BHLTYPE,BHLVALUE,BHLX

 +7        KILL C,D0,DA,DD,DI,DIADD,DIC,DIE,DIG,DIH,DIK,DIQUIET,DIU,DIV,DIW,DIX,DIY,DK,DL,DLAYGO,DO,DQ,DR,F,I,X,U

 +8        KILL C,IEN,SEX,DOB,F,X,Y

 +9        DO KILL^AUPNPAT

 +10       KILL X,Y,I

 +11       QUIT 

INIT      ;

 +1        KILL HLERR,APCDALVR,IEN

 +2       ;check to be sure that all required pieces of data are present

 +3       ;if not, set error and quit

 +4        SET (BHLR,BHLQUIT)=0

 +5        SET X=$GET(BHLBCH("TRANS"))

           IF X=""

               SET HLERR="TRANSACTION INFORMATION MISSING"

               SET BHLQUIT=1

               QUIT 

 +6        SET BHLTYPE=$PIECE(BHLBCH("TRANS"),U)

           IF BHLTYPE=""

               SET HLERR="TRANSACTION TYPE MISSING"

               SET BHLQUIT=1

               QUIT 

 +7        SET BHLID=$PIECE(BHLBCH("TRANS"),U,2)

           IF BHLID=""

               SET HLERR="TRANSACTION UNIQUE ID MISSING"

               SET BHLQUIT=1

               QUIT 

 +8        SET BHLID=$PIECE(BHLBCH("TRANS"),U,3)_BHLID

 +9        DO CHK^DIE(90002,.21,"E",BHLID,.BHLRES)

           IF BHLRES="^"

               SET HLERR="UNIQUE ID FAILED INPUT TRANSFORM"

               SET BHLQUIT=1

               QUIT 

 +10      ;must have a minimum of the record node to continue

           IF $GET(BHLBCH("REC"))=""

               SET HLERR="NO RECORD INFORMATION"

               SET BHLQUIT=1

               QUIT 

 +11      ;must have at least 1 pov to continue

           IF '$ORDER(BHLBCH("POV",0))

               SET BHLQUIT=1

               SET HLERR="NO POV PASSED"

               QUIT 

 +12      ;date,program,chr,prob code,svc code,svc min,act loc are all required to continue

 +13       FOR X=1:1:4

               SET Y=$PIECE(BHLBCH("REC"),U,X)

               IF Y=""

                   SET HLERR=$PIECE("DATE^PROGRAM^CHR^ACTLOC",U,X)_" REQUIRED ELEMENT MISSING"

                   SET BHLQUIT=1

                   QUIT 

 +14      ;chk pov

 +15       SET X=$ORDER(BHLBCH("POV",0))

           IF 'X

               SET HLERR="POV MISSING"

               SET BHLQUIT=1

               QUIT 

 +16       SET Y=BHLBCH("POV",X)

           FOR I=1:1:3

               IF $PIECE(Y,U,I)=""

                   SET HLERR=$PIECE("HLTH PROB CODE^SVC CODE^SVC MINS",U,I)_" REQUIRED ELEMENT MISSING"

                   SET BHLQUIT=1

                   QUIT 

 +17       QUIT 

PCCLINK   ;

 +1       ;add,edit or delete

           SET BCHEV("TYPE")="A"

 +2        SET BCHR=BHLR

 +3        DO PROTOCOL^BCHUADD1

 +4        KILL BCHEV,BCHR

 +5        QUIT 

A         ;

 +1        DO A^BHLBCH2

 +2        QUIT 

M         ;edit - delete original and do add

 +1        DO E^BHLBCH2

 +2        QUIT 

FMKILL    ;

 +1        KILL DIE,DIC,DA,DR,DLAYGO,DIADD,DIU,DIY,DIX,DIV,DIW,DD,D0,DO,DI,DK,DIG,DIH,DL,DQ

 +2        QUIT 

EDIT      ;edit all passed data, check against input tx

 +1       ;edit record info against input transform

 +2        SET BHLT="REC"

           DO CHECK

 +3        IF BHLQUIT

               QUIT 

 +4        SET BHLT="POV"

           SET BHLI=0

           FOR 

               SET BHLI=$ORDER(BHLBCH("POV",BHLI))

               IF BHLI=""!(BHLQUIT)

                   QUIT 

               DO CHECK

 +5        IF BHLQUIT

               QUIT 

 +6        IF $PIECE(BHLBCH("REC"),U,4)="HC"

               IF $PIECE(BHLBCH("REC"),U,12)=""

                   SET HLERR="IF ACT LOCATION IS HOSP MUST BE CLINIC NAME"

                   SET BHLQUIT=1

                   QUIT 

DEM       ;

 +1        IF $DATA(BHLBCH("DEMO"))

               Begin DoDot:1

 +2                FOR I=3:1:7

                       SET X=$PIECE(BHLBCH("DEMO"),U,I)

                       IF X["--"

                           SET $PIECE(BHLBCH("DEMO"),U,I)=""

 +3                SET BHLT="DEMO"

                   DO CHECK

               End DoDot:1

 +4        IF BHLQUIT

               QUIT 

ETESTS    ;edit tests and measurements

 +1        SET BHLFILE=90002

 +2        IF $DATA(BHLBCH("MSR"))

               SET BHLN=0

               FOR 

                   SET BHLN=$ORDER(BHLBCH("MSR",BHLN))

                   IF BHLN'=+BHLN!(BHLQUIT)

                       QUIT 

                   SET BHLMTYP=$PIECE(BHLBCH("MSR",BHLN),U)

                   SET BHLVALUE=$PIECE(BHLBCH("MSR",BHLN),U,2)

                   Begin DoDot:1

 +3                    IF BHLVALUE=""

                           QUIT 

 +4                    IF BHLMTYP="VU"!(BHLMTYP="VC")

                           Begin DoDot:2

 +5                            SET X=$PIECE(BHLBCH("MSR",BHLN),U,2)

 +6                            SET BHLVALUE=$PIECE($PIECE(BHLVALUE,"~"),"/",2)_"/"_$PIECE($PIECE(BHLVALUE,"~",2),"/",2)

                               SET $PIECE(BHLBCH("MSR",BHLN),U,2)=BHLVALUE

                           End DoDot:2

 +7                    SET BHLTIEN=$ORDER(^BCHTMT("B",BHLMTYP,0))

                       IF BHLTIEN=""

                           SET BHLQUIT=1

                           SET HLERR="MEASUREMENT TYPE NOT FOUND IN TABLE"

                           QUIT 

 +8                    SET BHLFIELD=$PIECE(^BCHTMT(BHLTIEN,0),U,3)

                       IF BHLFIELD=""

                           QUIT 

 +9                    KILL Y,BHLRES

                       SET DIQUIET=1

                       DO CHK^DIE(BHLFILE,BHLFIELD,"E",BHLVALUE,.BHLRES)

 +10                   IF BHLRES="^"

                           SET BHLQUIT=1

                           SET HLERR=BHLMTYP_" FAILED INPUT TRANSFORM EDIT"

                           QUIT 

 +11                   SET BHLFDA(BHLFILE,BHLR_",",BHLFIELD)=BHLRES

 +12                   QUIT 

                   End DoDot:1

 +13       QUIT 

CHECK     ;

 +1        SET BHLFILE=$PIECE($TEXT(@BHLT),";;",2)

           FOR BHLJ=1:1

               SET BHLX=$TEXT(@BHLT+BHLJ)

               SET BHLPIECE=$PIECE(BHLX,";;",2)

               IF BHLPIECE="QUIT"!(BHLPIECE="")!(BHLQUIT)

                   QUIT 

               Begin DoDot:1

 +2                KILL BHLRES

                   SET BHLITEM=$PIECE(BHLX,";;",3)

                   SET BHLFIELD=$PIECE(BHLX,";;",4)

                   SET BHLE=$PIECE(BHLX,";;",5)

 +3                IF BHLT="POV"

                       SET X=BHLBCH(BHLT,BHLI)

                   IF BHLT'="POV"

                       SET X=BHLBCH(BHLT)

                   SET X=$PIECE(X,U,BHLPIECE)

 +4                IF X=""

                       QUIT 

 +5                IF BHLE]""

                       Begin DoDot:2

 +6                        XECUTE BHLE

                           IF '$DATA(X)

                               SET HLERR=BHLITEM_" FAILED INPUT TX EDIT"

                               SET BHLQUIT=1

                               QUIT 

 +7                        IF BHLFILE=90002

                               SET BHLFDA(BHLFILE,BHLR_",",BHLFIELD)=X

                       End DoDot:2

                       QUIT 

 +8                KILL Y,BHLRES

                   SET DIQUIET=1

                   DO CHK^DIE(BHLFILE,BHLFIELD,"E",X,.BHLRES)

 +9                IF BHLRES="^"

                       SET BHLQUIT=1

                       SET HLERR=BHLITEM_" FAILED INPUT TRANSFORM EDIT"

                       QUIT 

 +10               IF BHLFILE=90002

                       SET BHLFDA(BHLFILE,BHLR_",",BHLFIELD)=BHLRES

 +11               QUIT 

               End DoDot:1

 +12       QUIT 

 +13      ;

CREATE    ;create record in CHR RECORD using FILE^DICN

 +1        SET BHLR=$ORDER(^BCHR("CUI",BHLID,0))

           IF BHLR

               SET BHLTYPE="M"

               QUIT 

 +2        DO FMKILL^BHLBCH2

 +3        SET DIC="^BCHR("

           SET DIC(0)="L"

           SET X=$PIECE($PIECE(BHLBCH("REC"),U),"@")

           SET %DT="T"

           DO ^%DT

           SET X=Y

           SET DLAYGO=90002

           SET DIC("DR")=".16////"_DUZ_";.17////"_DT_";.22////"_DT_";.26////R"

           KILL DD,DO

           DO FILE^DICN

 +4        IF Y=-1

               SET HLERR="CREATING CHR RECORD ENTRY FAILED"

               SET BHLQUIT=1

               QUIT 

 +5        SET BHLR=+Y

 +6        QUIT 

REC       ;;90002

 +1       ;;1;;DATE;;.01

 +2       ;;2;;PROGRAM;;.02;;

 +3       ;;3;;CHR;;.03;;

 +4       ;;4;;ACT LOC;;.06;;

 +5       ;;5;;REFERRED TO;;.07;;

 +6       ;;6;;REFERRED BY;;.08;;

 +7       ;;7;;EVALUATION;;.09;;

 +8       ;;8;;TRAVEL TIME;;.11;;

 +9       ;;9;;# SERVED;;.12;;

 +10      ;;10;;INSURER;;2102;;

 +11      ;;11;;PURP REFERRAL;;2101;;

 +12      ;;12;;LOC OF ENCOUNTER;;.05;;

 +13      ;;QUIT

POV       ;;90002.01

 +1       ;;1;;HLTH PROB CODE;;.01;;S Y=$O(^BCHTPROB("C",X,0)) K:'Y X I Y S X="`"_Y

 +2       ;;2;;SVC CODE;;.04;;S Y=$O(^BCHTSERV("D",X,0)) K:'Y X I Y S X="`"_X

 +3       ;;3;;SVC MINS;;.05;;

 +4       ;;4;;NARRATIVE;;.06;;X $P(^DD(9999999.27,.01,0),U,5,99)

 +5       ;;5;;SUBSTANCE RELATED;;.07;;

 +6       ;;QUIT

DEMO      ;;90002

 +1       ;;1;;PATIENT NAME;;1101;;

 +2       ;;2;;DATE OF BIRTH;;1102;;

 +3       ;;3;;SEX;;1103;;

 +4       ;;4;;SSN;;1104;;

 +5       ;;5;;TRIBE;;1105;;

 +6       ;;6;;COMMUNITY OF RESIDENCE;;1106;;S Y=$O(^AUTTCOM("C",X,0)) K:'Y X I Y S X=Y

 +7       ;;7;;CHART NUMBER;;1111;;

 +8       ;;8;;CHART FACILITY;;1109;;

 +9       ;;9;;TEMP RESIDENCE;;1108;;

 +10      ;;QUIT