| 1 | QACUTIL ;HISC/DAD-Utilities ;1/31/95 09:51
|
|---|
| 2 | ;;2.0;Patient Representative;**3**;07/25/1995
|
|---|
| 3 | EN1(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
|
|---|
| 14 | EN2 ;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
|
|---|
| 29 | EN3 ;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
|
|---|
| 39 | EN4(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
|
|---|
| 45 | EN5(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
|
|---|
| 53 | EN6(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
|
|---|
| 59 | EN7(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
|
|---|
| 63 | EN8(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
|
|---|
