source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL2.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.3 KB
RevLine 
[613]1ALPBUTL2 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
3 ;
4DELALG(IEN) ; delete allergies...
5 ; IEN = the patient's record number in file 53.7
6 ; deletes any allergies in the patient's record -- returns nothing
7 I +$G(IEN)=0 Q
8 I +$O(^ALPB(53.7,IEN,1,0))=0 Q
9 N ALPBX,DA,DIK,X,Y
10 S ALPBX=0
11 F S ALPBX=$O(^ALPB(53.7,IEN,1,ALPBX)) Q:'ALPBX D
12 .S DA=ALPBX
13 .S DA(1)=IEN
14 .S DIK="^ALPB(53.7,"_DA(1)_",1,"
15 .D ^DIK
16 .K DA,DIK
17 Q
18 ;
19GETPID(DATA,FS,CS,ECH,RESULTS) ; retrieve specific patient ID data from
20 ; PID segment...
21 ; DATA = HL7 data string
22 ; FS = HL7 field separator character
23 ; CS = HL7 component separator character
24 ; ECH = HL7 separators string
25 ; RESULTS = an array passed by reference into which retrieved data
26 ; is returned patient's DFN
27 S RESULTS(1)=$P($P(DATA,FS,4),CS,1)
28 ; name...
29 S RESULTS(2)=$$FMNAME^HLFNC($P(DATA,FS,6),ECH)
30 ; ssn (strip any dashes)...
31 S RESULTS(3)=$$STRIP^XLFSTR($P($P(DATA,FS,3),CS,1),"-")
32 ; dob...
33 S RESULTS(4)=$$FMDATE^HLFNC($P(DATA,FS,8))
34 ; gender...
35 S RESULTS(5)=$P(DATA,FS,9)
36 Q
37 ;
38GETORC(DATA,FS,CS,RESULTS) ; retrieve order number, date, type, and
39 ; CPRS order number from ORC segment...
40 ; DATA = HL7 data string
41 ; FS = HL7 field separator character
42 ; CS = HL7 component separator character
43 ; RESULTS = an array passed by reference into which retrieved data
44 ; is returned order action
45 S RESULTS(0)=$P(DATA,FS,2)
46 ; order number...
47 S RESULTS(1)=$P($P(DATA,FS,4),CS,1)
48 ; order date/time...
49 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:"")
50 ; CPRS order number...
51 S RESULTS(3)=+$P(DATA,FS,3)
52 ; order type...
53 S RESULTS(4)=$E(RESULTS(1),$L(RESULTS(1)))
54 Q
55 ;
56DELERR(IEN) ; delete an entry from the Error Log...
57 ; IEN = the Error Log record number
58 N ALPBPARM,DA,DIK,X,Y
59 S ALPBPARM=+$O(^ALPB(53.71,0))
60 I ALPBPARM'>0 Q
61 S DA=IEN
62 S DA(1)=ALPBPARM
63 S DIK="^ALPB(53.71,"_DA(1)_",1,"
64 D ^DIK
65 Q
66 ;
67ERRCT() ; fetch and return count of errors in the log in BCMA BACKUP PARAMETERS
68 ; file...
69 ; returns count of errors
70 N ALPBPARM,ALPBCNT,ALPBX
71 S ALPBPARM=+$O(^ALPB(53.71,0))
72 I ALPBPARM'>0 Q 0
73 S (ALPBCNT,ALPBX)=0
74 F S ALPBX=$O(^ALPB(53.71,ALPBPARM,1,"B",ALPBX)) Q:'ALPBX S ALPBCNT=ALPBCNT+1
75 Q ALPBCNT
76 ;
77REPL(X,Y) ; replace non-alpha and non-numeric characters...
78 ; X = a string to examine
79 ; Y = a character to use as the replacment
80 ; returns a string with any non-alpha and non-numeric characters
81 ; converted to the character passed in Y
82 I $G(X)=""!($G(Y)="") Q X
83 N I,NEWSTR,NEWX,Z
84 S NEWSTR=""
85 F I=1:1:$L(X) D
86 .S (NEWX,Z)=$E(X,I)
87 .I $A(Z)<48&($A(Z)'=44) S NEWX=Y
88 .I $A(Z)>57&($A(Z)<65) S NEWX=Y
89 .I $A(Z)>90&($A(Z)<97) S NEWX=Y
90 .I $A(Z)>122 S NEWX=Y
91 .S NEWSTR=NEWSTR_NEWX
92 Q NEWSTR
93 ;
94CLORD(IEN,OIEN) ; delete drug(s), additive(s) and/or solution(s) entries
95 ; for a specified order...
96 ; IEN = patient's record number in file 53.7
97 ; OIEN = order's sub-record number in file 53.7
98 ; returns nothing
99 I +$G(IEN)=0!(+$G(OIEN)=0) Q
100 N DA,DIK,SUB,X,XIEN,Y
101 F SUB=7,8,9 D
102 .S XIEN=0
103 .F S XIEN=$O(^ALPB(53.7,IEN,2,OIEN,SUB,XIEN)) Q:'XIEN D
104 ..S DA=XIEN
105 ..S DA(1)=OIEN
106 ..S DA(2)=IEN
107 ..S DIK="^ALPB(53.7,"_DA(2)_",2,"_DA(1)_","_SUB_","
108 ..D ^DIK
109 ..K DA,DIK
110 .K XIEN
111 Q
Note: See TracBrowser for help on using the repository browser.