ALPBUTL2 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
;
DELALG(IEN) ; delete allergies...
; IEN = the patient's record number in file 53.7
; deletes any allergies in the patient's record -- returns nothing
I +$G(IEN)=0 Q
I +$O(^ALPB(53.7,IEN,1,0))=0 Q
N ALPBX,DA,DIK,X,Y
S ALPBX=0
F S ALPBX=$O(^ALPB(53.7,IEN,1,ALPBX)) Q:'ALPBX D
.S DA=ALPBX
.S DA(1)=IEN
.S DIK="^ALPB(53.7,"_DA(1)_",1,"
.D ^DIK
.K DA,DIK
Q
;
GETPID(DATA,FS,CS,ECH,RESULTS) ; retrieve specific patient ID data from
; PID segment...
; DATA = HL7 data string
; FS = HL7 field separator character
; CS = HL7 component separator character
; ECH = HL7 separators string
; RESULTS = an array passed by reference into which retrieved data
; is returned patient's DFN
S RESULTS(1)=$P($P(DATA,FS,4),CS,1)
; name...
S RESULTS(2)=$$FMNAME^HLFNC($P(DATA,FS,6),ECH)
; ssn (strip any dashes)...
S RESULTS(3)=$$STRIP^XLFSTR($P($P(DATA,FS,3),CS,1),"-")
; dob...
S RESULTS(4)=$$FMDATE^HLFNC($P(DATA,FS,8))
; gender...
S RESULTS(5)=$P(DATA,FS,9)
Q
;
GETORC(DATA,FS,CS,RESULTS) ; retrieve order number, date, type, and
; CPRS order number from ORC segment...
; DATA = HL7 data string
; FS = HL7 field separator character
; CS = HL7 component separator character
; RESULTS = an array passed by reference into which retrieved data
; is returned order action
S RESULTS(0)=$P(DATA,FS,2)
; order number...
S RESULTS(1)=$P($P(DATA,FS,4),CS,1)
; order date/time...
S RESULTS(2)=$S($P(DATA,FS,16)'="":$$FMDATE^HLFNC($P(DATA,FS,16)),$P(DATA,FS,10)'="":$$FMDATE^HLFNC($P(DATA,FS,10)),1:"")
; CPRS order number...
S RESULTS(3)=+$P(DATA,FS,3)
; order type...
S RESULTS(4)=$E(RESULTS(1),$L(RESULTS(1)))
Q
;
DELERR(IEN) ; delete an entry from the Error Log...
; IEN = the Error Log record number
N ALPBPARM,DA,DIK,X,Y
S ALPBPARM=+$O(^ALPB(53.71,0))
I ALPBPARM'>0 Q
S DA=IEN
S DA(1)=ALPBPARM
S DIK="^ALPB(53.71,"_DA(1)_",1,"
D ^DIK
Q
;
ERRCT() ; fetch and return count of errors in the log in BCMA BACKUP PARAMETERS
; file...
; returns count of errors
N ALPBPARM,ALPBCNT,ALPBX
S ALPBPARM=+$O(^ALPB(53.71,0))
I ALPBPARM'>0 Q 0
S (ALPBCNT,ALPBX)=0
F S ALPBX=$O(^ALPB(53.71,ALPBPARM,1,"B",ALPBX)) Q:'ALPBX S ALPBCNT=ALPBCNT+1
Q ALPBCNT
;
REPL(X,Y) ; replace non-alpha and non-numeric characters...
; X = a string to examine
; Y = a character to use as the replacment
; returns a string with any non-alpha and non-numeric characters
; converted to the character passed in Y
I $G(X)=""!($G(Y)="") Q X
N I,NEWSTR,NEWX,Z
S NEWSTR=""
F I=1:1:$L(X) D
.S (NEWX,Z)=$E(X,I)
.I $A(Z)<48&($A(Z)'=44) S NEWX=Y
.I $A(Z)>57&($A(Z)<65) S NEWX=Y
.I $A(Z)>90&($A(Z)<97) S NEWX=Y
.I $A(Z)>122 S NEWX=Y
.S NEWSTR=NEWSTR_NEWX
Q NEWSTR
;
CLORD(IEN,OIEN) ; delete drug(s), additive(s) and/or solution(s) entries
; for a specified order...
; IEN = patient's record number in file 53.7
; OIEN = order's sub-record number in file 53.7
; returns nothing
I +$G(IEN)=0!(+$G(OIEN)=0) Q
N DA,DIK,SUB,X,XIEN,Y
F SUB=7,8,9 D
.S XIEN=0
.F S XIEN=$O(^ALPB(53.7,IEN,2,OIEN,SUB,XIEN)) Q:'XIEN D
..S DA=XIEN
..S DA(1)=OIEN
..S DA(2)=IEN
..S DIK="^ALPB(53.7,"_DA(2)_",2,"_DA(1)_","_SUB_","
..D ^DIK
..K DA,DIK
.K XIEN
Q
ALPBUTL2 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
+1 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
+2 ;
DELALG(IEN) ; delete allergies...
+1 ; IEN = the patient's record number in file 53.7
+2 ; deletes any allergies in the patient's record -- returns nothing
+3 IF +$GET(IEN)=0
QUIT
+4 IF +$ORDER(^ALPB(53.7,IEN,1,0))=0
QUIT
+5 NEW ALPBX,DA,DIK,X,Y
+6 SET ALPBX=0
+7 FOR
SET ALPBX=$ORDER(^ALPB(53.7,IEN,1,ALPBX))
IF 'ALPBX
QUIT
Begin DoDot:1
+8 SET DA=ALPBX
+9 SET DA(1)=IEN
+10 SET DIK="^ALPB(53.7,"_DA(1)_",1,"
+11 DO ^DIK
+12 KILL DA,DIK
End DoDot:1
+13 QUIT
+14 ;
GETPID(DATA,FS,CS,ECH,RESULTS) ; retrieve specific patient ID data from
+1 ; PID segment...
+2 ; DATA = HL7 data string
+3 ; FS = HL7 field separator character
+4 ; CS = HL7 component separator character
+5 ; ECH = HL7 separators string
+6 ; RESULTS = an array passed by reference into which retrieved data
+7 ; is returned patient's DFN
+8 SET RESULTS(1)=$PIECE($PIECE(DATA,FS,4),CS,1)
+9 ; name...
+10 SET RESULTS(2)=$$FMNAME^HLFNC($PIECE(DATA,FS,6),ECH)
+11 ; ssn (strip any dashes)...
+12 SET RESULTS(3)=$$STRIP^XLFSTR($PIECE($PIECE(DATA,FS,3),CS,1),"-")
+13 ; dob...
+14 SET RESULTS(4)=$$FMDATE^HLFNC($PIECE(DATA,FS,8))
+15 ; gender...
+16 SET RESULTS(5)=$PIECE(DATA,FS,9)
+17 QUIT
+18 ;
GETORC(DATA,FS,CS,RESULTS) ; retrieve order number, date, type, and
+1 ; CPRS order number from ORC segment...
+2 ; DATA = HL7 data string
+3 ; FS = HL7 field separator character
+4 ; CS = HL7 component separator character
+5 ; RESULTS = an array passed by reference into which retrieved data
+6 ; is returned order action
+7 SET RESULTS(0)=$PIECE(DATA,FS,2)
+8 ; order number...
+9 SET RESULTS(1)=$PIECE($PIECE(DATA,FS,4),CS,1)
+10 ; order date/time...
+11 SET RESULTS(2)=$SELECT($PIECE(DATA,FS,16)'="":$$FMDATE^HLFNC($PIECE(DATA,FS,16)),$PIECE(DATA,FS,10)'="":$$FMDATE^HLFNC($PIECE(DATA,FS,10)),1:"")
+12 ; CPRS order number...
+13 SET RESULTS(3)=+$PIECE(DATA,FS,3)
+14 ; order type...
+15 SET RESULTS(4)=$EXTRACT(RESULTS(1),$LENGTH(RESULTS(1)))
+16 QUIT
+17 ;
DELERR(IEN) ; delete an entry from the Error Log...
+1 ; IEN = the Error Log record number
+2 NEW ALPBPARM,DA,DIK,X,Y
+3 SET ALPBPARM=+$ORDER(^ALPB(53.71,0))
+4 IF ALPBPARM'>0
QUIT
+5 SET DA=IEN
+6 SET DA(1)=ALPBPARM
+7 SET DIK="^ALPB(53.71,"_DA(1)_",1,"
+8 DO ^DIK
+9 QUIT
+10 ;
ERRCT() ; fetch and return count of errors in the log in BCMA BACKUP PARAMETERS
+1 ; file...
+2 ; returns count of errors
+3 NEW ALPBPARM,ALPBCNT,ALPBX
+4 SET ALPBPARM=+$ORDER(^ALPB(53.71,0))
+5 IF ALPBPARM'>0
QUIT 0
+6 SET (ALPBCNT,ALPBX)=0
+7 FOR
SET ALPBX=$ORDER(^ALPB(53.71,ALPBPARM,1,"B",ALPBX))
IF 'ALPBX
QUIT
SET ALPBCNT=ALPBCNT+1
+8 QUIT ALPBCNT
+9 ;
REPL(X,Y) ; replace non-alpha and non-numeric characters...
+1 ; X = a string to examine
+2 ; Y = a character to use as the replacment
+3 ; returns a string with any non-alpha and non-numeric characters
+4 ; converted to the character passed in Y
+5 IF $GET(X)=""!($GET(Y)="")
QUIT X
+6 NEW I,NEWSTR,NEWX,Z
+7 SET NEWSTR=""
+8 FOR I=1:1:$LENGTH(X)
Begin DoDot:1
+9 SET (NEWX,Z)=$EXTRACT(X,I)
+10 IF $ASCII(Z)<48&($ASCII(Z)'=44)
SET NEWX=Y
+11 IF $ASCII(Z)>57&($ASCII(Z)<65)
SET NEWX=Y
+12 IF $ASCII(Z)>90&($ASCII(Z)<97)
SET NEWX=Y
+13 IF $ASCII(Z)>122
SET NEWX=Y
+14 SET NEWSTR=NEWSTR_NEWX
End DoDot:1
+15 QUIT NEWSTR
+16 ;
CLORD(IEN,OIEN) ; delete drug(s), additive(s) and/or solution(s) entries
+1 ; for a specified order...
+2 ; IEN = patient's record number in file 53.7
+3 ; OIEN = order's sub-record number in file 53.7
+4 ; returns nothing
+5 IF +$GET(IEN)=0!(+$GET(OIEN)=0)
QUIT
+6 NEW DA,DIK,SUB,X,XIEN,Y
+7 FOR SUB=7,8,9
Begin DoDot:1
+8 SET XIEN=0
+9 FOR
SET XIEN=$ORDER(^ALPB(53.7,IEN,2,OIEN,SUB,XIEN))
IF 'XIEN
QUIT
Begin DoDot:2
+10 SET DA=XIEN
+11 SET DA(1)=OIEN
+12 SET DA(2)=IEN
+13 SET DIK="^ALPB(53.7,"_DA(2)_",2,"_DA(1)_","_SUB_","
+14 DO ^DIK
+15 KILL DA,DIK
End DoDot:2
+16 KILL XIEN
End DoDot:1
+17 QUIT
