Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCHLR

DVBCHLR.m

Go to the documentation of this file.
  1. DVBCHLR ;ALB/JLU-Processes the results from the ORU ;1/28/93
  1. ;;2.7;AMIE;**9,193**;Apr 10, 1995;Build 84
  1. ;
  1. BEG D INIT
  1. F D @$S(DVBCX="PID"&'$D(HLERR):"PID",DVBCX="OBR"&'$D(HLERR):"OBR",DVBCX="OBX"&'$D(HLERR):"OBX",1:"ACK") Q:DVBCX="QUIT"
  1. D EXIT
  1. Q
  1. ;
  1. EXIT K %,DA,DFN,DIE,DR,DVBC,HLERR,DVBCNT2,DVBCOBR,DVBCOBX,DVBCOBXV,DVBCPAT,DVBCPDFN,DVBCPID,DVBCRPDT,DVBCSAV,DVBCSSN,DVBCUEX,DVBCUEXT,DVBCUNIV,DVBCURQ,DVBCX,DVBCX1,DVBX,VADM,VAERR,DVBCEXAM,DVBCST,DVBCELCT,DVBCUEX1
  1. Q
  1. ;
  1. INIT ;initializes and checks variables
  1. S DVBCX="PID",DVBC=1
  1. I '$D(HLESIG) S HLERR="No Electronic Signature code present, updating cannot be allowed."
  1. I $S('$D(HLDUZ):1,HLDUZ']"":1,1:0) S HLERR="Not a valid DHCP user number."
  1. Q
  1. ;
  1. PID ;Brake apart the PID section
  1. K HLERR,DVBCPID,DVBCSSN,DVBCPDFN,DVBCPAT,DFN,VAERR,VADM
  1. S DVBC=$O(^HL(772,HLDA,"IN",DVBC))
  1. I 'DVBC S HLERR="Missing PID Segment" Q
  1. S DVBCPID=^(DVBC,0) ;NAKE FROM ^HL(772,HLDA,IN PID+2
  1. I $P(DVBCPID,HLFS,1)'="PID" S HLERR="Incorrect PID Segment indicator" Q
  1. I $P(DVBCPID,HLFS,4)']"" S HLERR="Internal Patient ID Missing" Q
  1. I $P(DVBCPID,HLFS,6)']"" S HLERR="Patient Name Invalid" Q
  1. I $P(DVBCPID,HLFS,20)']"" S HLERR="Patient SSN Invalid" Q
  1. S DVBCSSN=$P(DVBCPID,HLFS,20)
  1. S DVBCPDFN=+$P(DVBCPID,HLFS,4)
  1. S DVBCPAT=$$FMNAME^HLFNC($P(DVBCPID,HLFS,6))
  1. S DFN=DVBCPDFN
  1. D DEM^VADPT
  1. I VAERR S HLERR="Incorrect Patient Identifier" Q
  1. I DVBCSSN'=$P(VADM(2),U,1) S HLERR="Invalid SSN" Q
  1. S DVBCX="OBR"
  1. Q
  1. ;
  1. OBR ;Parsing the OBR segment.
  1. K DVBCOBR,DVBCUNIV
  1. F S DVBC=$O(^HL(772,HLDA,"IN",DVBC)) Q:DVBC="" S DVBCOBR=^(DVBC,0) Q:$P(DVBCOBR,HLFS,1)="OBR"
  1. I DVBC="" S HLERR="Missing OBR Segment" Q
  1. I $P(DVBCOBR,HLFS,5)']"" S HLERR="Missing Universal Identifier" Q
  1. I $P(DVBCOBR,HLFS,21)']"" S HLERR="Missing Exam Type" Q
  1. I $P(DVBCOBR,HLFS,23)']"" S HLERR="Missing Report Date" Q
  1. S DVBCUNIV=$P(DVBCOBR,HLFS,5)
  1. S DVBCUEXT=$P(DVBCOBR,HLFS,21)
  1. S DVBCRPDT=$$FMDATE^HLFNC($P(DVBCOBR,HLFS,23))
  1. S DVBCURQ=$P(DVBCUNIV,$E(HLECH),1)
  1. S DVBCUEX=$P(DVBCUNIV,$E(HLECH),2)
  1. I '$D(^DVB(396.3,DVBCURQ,0)) S HLERR="Request No longer Exists" Q
  1. I "PS"'[$P(^(0),U,18) S HLERR="Status of Request will not allow for down loading" Q ;NAKED FROM LINE BEFORE
  1. I '$D(^DVB(396.4,DVBCUEX,0)) S HLERR="Exam No longer Exists" Q
  1. S DVBCUEX1=^DVB(396.4,DVBCUEX,0)
  1. I "RXT"[$P(DVBCUEX1,U,4) S HLERR="Exam status not open, no down loading allow* ed" Q
  1. D HASH^DVBCHLUT
  1. I '$D(DVBCELCT) S HLERR="Bad electronic signature code." Q
  1. I $P(DVBCUEX1,U,4)="C",$P(DVBCUEX1,U,10)'=DVBCELCT S HLERR="Electronic signature codes do not match, no down loading allowed" Q
  1. S DVBCX="OBX"
  1. Q
  1. ;
  1. OBX ;looping through the OBX segment
  1. K DVBCSAV
  1. S DVBCNT2=0,DVBCSAV=DVBC
  1. I '$$LOCK^DVBCHLUT(DVBCURQ,DVBCUEX) Q
  1. D DEL
  1. F S DVBC=$O(^HL(772,HLDA,"IN",DVBC)) S:DVBC="" DVBCX="ACK" Q:DVBC="" S DVBCOBX=^(DVBC,0) D OBX1 Q:DVBCX'="OBX" S DVBCSAV=DVBC
  1. S DVBC=DVBCSAV
  1. I 'DVBCNT2 S HLERR="Invalid OBX Segment" D UNLOCK^DVBCHLUT(DVBCURQ,DVBCUEX) Q
  1. I DVBCNT2 D CLOSE
  1. D UNLOCK^DVBCHLUT(DVBCURQ,DVBCUEX)
  1. Q
  1. ;
  1. OBX1 ;
  1. S DVBCOBXV=$P(DVBCOBX,HLFS,1)
  1. I DVBCOBXV="NTE" Q
  1. I $S(DVBCOBXV="PID":1,DVBCOBXV="OBR":1,1:0) S DVBCX=DVBCOBXV Q
  1. I DVBCOBXV'="OBX" S DVBCX="ACK" Q
  1. S DVBCNT2=DVBCNT2+1
  1. S ^DVB(396.4,DVBCUEX,"RES",DVBCNT2,0)=$P(DVBCOBX,HLFS,6)
  1. Q
  1. ;
  1. CLOSE ;sets exam fields and quits
  1. D NOW^%DTC
  1. S ^DVB(396.4,DVBCUEX,"RES",0)="^^"_DVBCNT2_"^"_DVBCNT2_"^"_%
  1. S DIE="^DVB(396.4,",DA=DVBCUEX
  1. S DR=".04///C;.06///^S X=DVBCRPDT;.07///^S X=$P(^VA(200,HLDUZ,0),U,1);.1///^S X=DVBCELCT"
  1. D ^DIE
  1. S DVBCEXAM=^DVB(396.4,DVBCUEX,0)
  1. I $P(DVBCEXAM,U,4)'="C"!($P(DVBCEXAM,U,6)']"")!$P(DVBCEXAM,U,7)']"" S HLERR="Results added but request and exam status not updated." Q
  1. D COMPL
  1. Q
  1. ;
  1. ACK ;setting up the acknowledgment segment.
  1. I $D(HLERR) S DVBCX1=HLSDATA(1) K HLSDATA S HLSDATA(1)=DVBCX1
  1. S HLSDATA(2)="MSA"_HLFS_$S($D(HLERR):"AE",1:"AA")_HLFS_HLMID_HLFS_$S($D(HLERR):HLERR,1:"")
  1. S DVBCX="QUIT"
  1. I $D(HLTRANS) D EN1^HLTRANS
  1. Q
  1. ;
  1. COMPL ;This subroutine will search the other exams and set the request's
  1. ;status to transcribed if able.
  1. ;This should become a callable subroutine because ^dvbcedit does the same
  1. ;
  1. K DVBCOPN
  1. F DVBC=0:0 S DVBC=$O(^DVB(396.4,"C",DVBCURQ,DVBC)) Q:'DVBC S DVBCST=$P(^DVB(396.4,DVBC,0),U,4) I DVBCST="O"!(DVBCST="T") S DVBCOPN=1 Q
  1. Q:$D(DVBCOPN)
  1. S XMDUZ="Kurzweil"
  1. S XMB="DVBA C 2507 EXAM READY"
  1. S XMB(1)=DVBCPAT,XMB(2)=DVBCSSN
  1. S Y=$P(^DVB(396.3,DVBCURQ,0),U,2)
  1. X ^DD("DD")
  1. S XMB(3)=Y
  1. D ^XMB
  1. K XMDUZ,XMB,Y
  1. S DIE="^DVB(396.3,",DA=DVBCURQ
  1. ;AJF;Request Status Conversion
  1. S DR="11///NOW;17////8"
  1. D ^DIE
  1. I $P(^DVB(396.3,DVBCURQ,0),U,12)']""!($P(^(0),U,18)'=8) S HLERR="Results added and exam status updated but request status not updated."
  1. Q
  1. ;
  1. DEL ;to delete the results from an exam if it is being resent.
  1. I $P(DVBCUEX1,U,10)]"" K ^DVB(396.4,DVBCUEX,"RES")
  1. Q