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
