source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACUTIL.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1QACUTIL ;HISC/DAD-Utilities ;1/31/95 09:51
2 ;;2.0;Patient Representative;**3**;07/25/1995
3EN1(Y) ;This utility returns the Code, Text and Quality Aspect
4 ;for entry Y.
5 N QAC,C
6 S QAC=$G(^QA(745.2,+Y,0))
7 I QAC]"" D
8 . S QAC(1)=$P(QAC,"^"),QAC(3)=$P(QAC,"^",3),QAC(4)=+$P(QAC,"^",4)
9 . S QAC(4)=$P($G(^QA(745.3,QAC(4),0)),"^",4)
10 . S Y=QAC(4),C=$P(^DD(745.3,.04,0),"^",2),QAC(4)=""
11 . I Y]"" D Y^DIQ S QAC(4)=Y
12 . S QAC=QAC(1)_" "_QAC(3)_" "_QAC(4)
13 Q QAC
14EN2 ;Utility to display Issue Code description (?Code)
15 Q:'$D(X) Q:(X'?1."?"1.2A2.3N) D HOME^%ZIS W !
16 N QACLINE,QACCODE,QACFOUND,QACQUIT,QACIFN0,QACIFN1,CODE
17 ;Get the code that follows '?'.
18 S QACLINE=$Y,(QACCODE,QACCODE(0))=$$UP^XLFSTR($P(X,"?",$L(X,"?")))
19 S (QACFOUND,QACQUIT,QACIFN0)=0
20 F S QACIFN0=$O(^QA(745.2,"B",QACCODE,QACIFN0)) Q:QACIFN0'>0!QACQUIT D
21 . ;Get code, name and description and display
22 . D EN^DDIOL($P(^QA(745.2,QACIFN0,0),U)_" "_$P(^(0),U,3))
23 . D EN^DDIOL(" ")
24 . D EN^DDIOL(" ")
25 . D EN^DDIOL("","^QA(745.2,QACIFN0,1)")
26 . S QACFOUND=1
27 I 'QACFOUND D EN^DDIOL("Code not found. Try again")
28 Q
29EN3 ;This utility returns a definition for the fields, Date Sent
30 ;and Date Closed.
31 Q:$D(DA)[0 N Y
32 S Y=$P(^QA(745.1,DA,0),"^",2)\1 X ^DD("DD")
33 D EN^DDIOL(" ")
34 D EN^DDIOL(" Must be on or after the contact date: "_Y)
35 S Y=DT X ^DD("DD") D EN^DDIOL(" and not later than: "_Y)
36 D EN^DDIOL(" ")
37 D EN^DDIOL(" ")
38 Q
39EN4(QACSIEN) ;This utility returns the Parent Service from file #49.
40 N QAC,QACSERV S QACSERV="UNKNOWN",QAC=$G(^DIC(49,+QACSIEN,0))
41 I QAC]"" D
42 . S QACSERV=$P($G(^DIC(49,+$P(QAC,U,4),0)),U,1)
43 . I QACSERV="" S QACSERV=$P(QAC,U,1)
44 Q QACSERV
45EN5(QACCIEN) ;This utility returns the Issue Code and the Issue Code Name
46 N QAC,QACCNM,QACCSS S QACCNM="UNKNOWN",QAC=$G(^QA(745.2,+QACCIEN,0))
47 I QAC]"" D
48 . S QAC(1)=$P(QAC,"^"),QAC(3)=$P(QAC,U,3)
49 . S QACCNM=QAC(1)_" "_$E(QAC(3),1,50)
50 . S QACCSS=$P($G(^QA(745.2,QACCIEN,0)),U,7)
51 . I QACCSS]"" S QACCNM=QACCNM_"(*"_$P($G(^QA(745.6,QACCSS,0)),U,2)_")"
52 Q QACCNM
53EN6(QACHDIEN) ;This utility returns the Header Issue Code and its name
54 N QAC,QACHDNM S QACHDNM="UNKNOWN",QAC=$G(^QA(745.2,+QACHDIEN,0))
55 I QAC]"" D
56 . S QAC(1)=$P(QAC,"^"),QAC(3)=$P(QAC,U,3)
57 . S QACHDNM=QAC(1)_" "_QAC(3)
58 Q QACHDNM
59EN7(QACDIEN) ;This utility returns the discipline involved
60 N QAC,QACDISC S QACDISC="UNKNOWN",QAC=$G(^QA(745.5,+QACDIEN,0))
61 I QAC]"" S QACDISC=$P($G(QAC),U,2)
62 Q QACDISC
63EN8(QACDIEN) ;This utility returns the service/section involved
64 N QAC,QACDISC S QACDISC="UNKNOWN",QAC=$G(^QA(745.55,+QACDIEN,0))
65 I QAC]"" S QACDISC=$P($G(QAC),U)
66 Q QACDISC
Note: See TracBrowser for help on using the repository browser.