- 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
