- BHLBCH2 ; IHS/TUCSON/DCP - HL7 ORU Message Processor (continued) ;
- ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
- ;
- ; This routine is a continuation of BHLBCH1.
- ; It is not independently callable.
- ;
- A ; ENTRY POINT from BHLBCH1
- ;
- D FILEREC Q:BHLQUIT
- D FILEDMO
- D FILEPOV
- D FILETEST
- Q
- ;
- E ; ENTRY POINT from BHLBCH1 - edit - delete original and do add
- ;
- S BCHR=BHLR,BCHSTOP=1 D DELETE^BCHUDEL K BCHSTOP
- D A
- Q
- ;
- FMKILL ; ENTRY POINT from BHLBCH1
- ;
- K DIE,DIC,DA,DR,DLAYGO,DIADD,DIU,DIY,DIX,DIV,DIW,DD,D0,DO,DI,DK,DIG,DIH,DL,DQ
- Q
- FILEREC ;create and file chr record
- S BHLFDA(90002,BHLR_",",.21)=BHLID
- D FILE^DIE("KS","BHLFDA","BHLERR")
- Q
- FILEPOV ;file povs
- K BHLTPOV
- D FMKILL
- Q:'$D(BHLBCH("POV"))
- S APCDOVRR=1
- S BHLN=0 F S BHLN=$O(BHLBCH("POV",BHLN)) Q:BHLN'=+BHLN D
- .S X=$P(BHLBCH("POV",BHLN),U),X=$O(^BCHTPROB("C",X,0)) I X="" S HLERR="POV PROBLEM CODE FAILED",BHLQUIT=1 Q
- .S DIC="^BCHRPROB(",DIC("DR")=".02////^S X=$G(IEN);.03////^S X=BHLR",DLAYGO=90002.01,DIADD=1,DIC(0)="L" D FILE^DICN
- .I Y=-1 S HLERR="ERROR IN DICN ADDING A POV",BHLQUIT=1 Q
- .S BHLPOV=+Y
- .D FMKILL
- .S DA=BHLPOV,DIE="^BCHRPROB("
- .S BHLSRV=$O(^BCHTSERV("D",$P(BHLBCH("POV",BHLN),U,2),0)),BHLSRV="`"_BHLSRV
- .S DR=".04///"_BHLSRV_";.05///"_$P(BHLBCH("POV",BHLN),U,3)_";.06///"_$P(BHLBCH("POV",BHLN),U,4)_";.07///"_$P(BHLBCH("POV",BHLN),U,5)
- .D ^DIE
- .I $D(Y) S HLERR="ERROR UPDATING POV RECORD - DIE",BHLQUIT=1
- .D FMKILL
- K APCDOVRR
- I '$D(HLERR) S BHLTPOV(BHLPOV)=""
- Q
- FILEDMO ;
- ;get patient based on chart number passed, check dob and sex - if same use IEN, otherwise do not
- S IEN=""
- Q:'$D(BHLBCH("DEMO"))
- S F=$P(BHLBCH("DEMO"),U,8) I F]"" S F=$O(^AUTTLOC("C",F,0))
- S C=$P(BHLBCH("DEMO"),U,7),SEX=$P(BHLBCH("DEMO"),U,3),DOB=$P(BHLBCH("DEMO"),U,2)
- I 'F!(C="") D NOIEN Q
- S BHLDUZ2=DUZ(2),DUZ(2)=F,X=C,DIC="^AUPNPAT(",DIC(0)="M" D ^DIC
- S DUZ(2)=BHLDUZ2 K BHLDUZ2 I +Y>0,SEX=$P(^DPT(+Y,0),U,2),DOB=$P(^DPT(+Y,0),U,3) S IEN=+Y,DIE="^BCHR(",DA=BHLR,DR=".04////^S X=IEN" D ^DIE D FMKILL D:$P(BHLBCH("DEMO"),U,9)]"" Q
- .S DIE="^BCHR(",DA=BHLR,DR="1108///"_$P(BHLBCH("DEMO"),U,9) D ^DIE I $D(Y) S HLERR="TEMPORARY RESIDENCE FAILED",BHLQUIT=1 Q
- .Q
- D NOIEN
- Q
- NOIEN ;stuff demo stuff - no IEN found
- D FMKILL
- S DIE="^BCHR(",DA=BHLR,DR="1101///"_$P(BHLBCH("DEMO"),U)_";1102///"_$P(BHLBCH("DEMO"),U,2)_";1103///"_$P(BHLBCH("DEMO"),U,3)_";1104///"_$P(BHLBCH("DEMO"),U,4)_";1111///"_$P(BHLBCH("DEMO"),U,7)_";1109///"_$P(BHLBCH("DEMO"),U,8)
- S DR=DR_";1107///"_$P(BHLBCH("DEMO"),U,6)_";1108///"_$P(BHLBCH("DEMO"),U,9)_";1105///"_$P(BHLBCH("DEMO"),U,5)_";1106///"_$P(BHLBCH("DEMO"),U,6)
- D ^DIE
- I $D(Y) S HLERR="ERROR UPDATING AN ITEM IN THE DEMO NODE",BHLQUIT=1
- Q
- FILETEST ;file all tests
- Q:'$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
- .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 ;this is temporary ************ only fields 1201-1210 work, will do lab tests later
- .;file measurement
- .D FMKILL S DIE="^BCHR(",DA=BHLR,DR=BHLFIELD_"///"_BHLVALUE D ^DIE
- .I $D(Y) S HLERR="DIE FAILED UPDATING "_BHLMTYP_" VALUE",BHLQUIT=1 Q
- .Q
- Q
- BHLBCH2 ; 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 BHLBCH1.
- +4 ; It is not independently callable.
- +5 ;
- A ; ENTRY POINT from BHLBCH1
- +1 ;
- +2 DO FILEREC
- IF BHLQUIT
- QUIT
- +3 DO FILEDMO
- +4 DO FILEPOV
- +5 DO FILETEST
- +6 QUIT
- +7 ;
- E ; ENTRY POINT from BHLBCH1 - edit - delete original and do add
- +1 ;
- +2 SET BCHR=BHLR
- SET BCHSTOP=1
- DO DELETE^BCHUDEL
- KILL BCHSTOP
- +3 DO A
- +4 QUIT
- +5 ;
- FMKILL ; ENTRY POINT from BHLBCH1
- +1 ;
- +2 KILL DIE,DIC,DA,DR,DLAYGO,DIADD,DIU,DIY,DIX,DIV,DIW,DD,D0,DO,DI,DK,DIG,DIH,DL,DQ
- +3 QUIT
- FILEREC ;create and file chr record
- +1 SET BHLFDA(90002,BHLR_",",.21)=BHLID
- +2 DO FILE^DIE("KS","BHLFDA","BHLERR")
- +3 QUIT
- FILEPOV ;file povs
- +1 KILL BHLTPOV
- +2 DO FMKILL
- +3 IF '$DATA(BHLBCH("POV"))
- QUIT
- +4 SET APCDOVRR=1
- +5 SET BHLN=0
- FOR
- SET BHLN=$ORDER(BHLBCH("POV",BHLN))
- IF BHLN'=+BHLN
- QUIT
- Begin DoDot:1
- +6 SET X=$PIECE(BHLBCH("POV",BHLN),U)
- SET X=$ORDER(^BCHTPROB("C",X,0))
- IF X=""
- SET HLERR="POV PROBLEM CODE FAILED"
- SET BHLQUIT=1
- QUIT
- +7 SET DIC="^BCHRPROB("
- SET DIC("DR")=".02////^S X=$G(IEN);.03////^S X=BHLR"
- SET DLAYGO=90002.01
- SET DIADD=1
- SET DIC(0)="L"
- DO FILE^DICN
- +8 IF Y=-1
- SET HLERR="ERROR IN DICN ADDING A POV"
- SET BHLQUIT=1
- QUIT
- +9 SET BHLPOV=+Y
- +10 DO FMKILL
- +11 SET DA=BHLPOV
- SET DIE="^BCHRPROB("
- +12 SET BHLSRV=$ORDER(^BCHTSERV("D",$PIECE(BHLBCH("POV",BHLN),U,2),0))
- SET BHLSRV="`"_BHLSRV
- +13 SET DR=".04///"_BHLSRV_";.05///"_$PIECE(BHLBCH("POV",BHLN),U,3)_";.06///"_$PIECE(BHLBCH("POV",BHLN),U,4)_";.07///"_$PIECE(BHLBCH("POV",BHLN),U,5)
- +14 DO ^DIE
- +15 IF $DATA(Y)
- SET HLERR="ERROR UPDATING POV RECORD - DIE"
- SET BHLQUIT=1
- +16 DO FMKILL
- End DoDot:1
- +17 KILL APCDOVRR
- +18 IF '$DATA(HLERR)
- SET BHLTPOV(BHLPOV)=""
- +19 QUIT
- FILEDMO ;
- +1 ;get patient based on chart number passed, check dob and sex - if same use IEN, otherwise do not
- +2 SET IEN=""
- +3 IF '$DATA(BHLBCH("DEMO"))
- QUIT
- +4 SET F=$PIECE(BHLBCH("DEMO"),U,8)
- IF F]""
- SET F=$ORDER(^AUTTLOC("C",F,0))
- +5 SET C=$PIECE(BHLBCH("DEMO"),U,7)
- SET SEX=$PIECE(BHLBCH("DEMO"),U,3)
- SET DOB=$PIECE(BHLBCH("DEMO"),U,2)
- +6 IF 'F!(C="")
- DO NOIEN
- QUIT
- +7 SET BHLDUZ2=DUZ(2)
- SET DUZ(2)=F
- SET X=C
- SET DIC="^AUPNPAT("
- SET DIC(0)="M"
- DO ^DIC
- +8 SET DUZ(2)=BHLDUZ2
- KILL BHLDUZ2
- IF +Y>0
- IF SEX=$PIECE(^DPT(+Y,0),U,2)
- IF DOB=$PIECE(^DPT(+Y,0),U,3)
- SET IEN=+Y
- SET DIE="^BCHR("
- SET DA=BHLR
- SET DR=".04////^S X=IEN"
- DO ^DIE
- DO FMKILL
- IF $PIECE(BHLBCH("DEMO"),U,9)]""
- Begin DoDot:1
- +9 SET DIE="^BCHR("
- SET DA=BHLR
- SET DR="1108///"_$PIECE(BHLBCH("DEMO"),U,9)
- DO ^DIE
- IF $DATA(Y)
- SET HLERR="TEMPORARY RESIDENCE FAILED"
- SET BHLQUIT=1
- QUIT
- +10 QUIT
- End DoDot:1
- QUIT
- +11 DO NOIEN
- +12 QUIT
- NOIEN ;stuff demo stuff - no IEN found
- +1 DO FMKILL
- +2 SET DIE="^BCHR("
- SET DA=BHLR
- SET DR="1101///"_$PIECE(BHLBCH("DEMO"),U)_";1102///"_$PIECE(BHLBCH("DEMO"),U,2)_";1103///"_$PIECE(BHLBCH("DEMO"),U,3)_";1104///"_$PIECE(BHLBCH("DEMO"),U,4)_";1111///"_$PIECE(BHLBCH("DEMO"),U,7)_";1109///"_$PIECE(BHLBCH("DEMO"),U,8)
- +3 SET DR=DR_";1107///"_$PIECE(BHLBCH("DEMO"),U,6)_";1108///"_$PIECE(BHLBCH("DEMO"),U,9)_";1105///"_$PIECE(BHLBCH("DEMO"),U,5)_";1106///"_$PIECE(BHLBCH("DEMO"),U,6)
- +4 DO ^DIE
- +5 IF $DATA(Y)
- SET HLERR="ERROR UPDATING AN ITEM IN THE DEMO NODE"
- SET BHLQUIT=1
- +6 QUIT
- FILETEST ;file all tests
- +1 IF '$DATA(BHLBCH("MSR"))
- QUIT
- +2 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 SET BHLTIEN=$ORDER(^BCHTMT("B",BHLMTYP,0))
- IF BHLTIEN=""
- SET BHLQUIT=1
- SET HLERR="MEASUREMENT TYPE NOT FOUND IN TABLE"
- QUIT
- +4 ;this is temporary ************ only fields 1201-1210 work, will do lab tests later
- SET BHLFIELD=$PIECE(^BCHTMT(BHLTIEN,0),U,3)
- IF BHLFIELD=""
- QUIT
- +5 ;file measurement
- +6 DO FMKILL
- SET DIE="^BCHR("
- SET DA=BHLR
- SET DR=BHLFIELD_"///"_BHLVALUE
- DO ^DIE
- +7 IF $DATA(Y)
- SET HLERR="DIE FAILED UPDATING "_BHLMTYP_" VALUE"
- SET BHLQUIT=1
- QUIT
- +8 QUIT
- End DoDot:1
- +9 QUIT
