source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCHS2.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1DVBCHS2 ;ALB/JRP - C & P EXTRACT FOR HEALTH SUMMARY (CONT);11-JAN-95
2 ;;2.7;AMIE;;Apr 10, 1995
3OUT1(PTR,ARR) ;SET NODE ONE OF OUTPUT
4 ;INPUT : PTR - Pointer to 2507 EXAM file (#396.4)
5 ; ARR - Where to place output (full global reference)
6 ;OUTPUT : None
7 ; See HSCP^DVBCHS0() for format of output array
8 ;NOTES : All input is assumed to exist (no error checking)
9 ;
10 N CODE,NODE,LOCPTR,LOCATION,OWNPTR,OWNER,OUTPTR
11 N TYPEPTR,FMDATE,REQPTR,OUTDOM,INVDATE
12 ;DETERMINE CODE (BASED ON TRANSFER OUT/IN DATES)
13 S NODE=$G(^DVB(396.4,PTR,"TRAN"))
14 ;DONE AT LOCAL FACILITY
15 S CODE=1
16 ;DONE AT REMOTE FACILITY
17 S:($P(NODE,"^",1)'="") CODE=2
18 ;DONE AT LOCAL FACILITY FOR REMOTE FACILITY
19 S:($P(NODE,"^",4)'="") CODE=3
20 ;GET ROUTING LOCATION
21 S REQPTR=+$P($G(^DVB(396.4,PTR,0)),"^",2)
22 S LOCPTR=+$P($G(^DVB(396.3,REQPTR,1)),"^",4)
23 S LOCATION=$P($G(^DG(40.8,LOCPTR,0)),"^",1)
24 S:('LOCPTR) LOCATION="UNKNOWN"
25 ;DEFAULT REMOTE DOMAINS TO N/A
26 S OWNER="N/A"
27 S OUTDOM="N/A"
28 ;EXAM DONE REMOTELY
29 I (CODE=2) D
30 .S OUTPTR=+$P($G(^DVB(396.4,PTR,"TRAN")),"^",3)
31 .S OUTDOM=$P($G(^DIC(4.2,OUTPTR,0)),"^",1)
32 .S:('OUTPTR) OUTDOM="UNKNOWN"
33 ;EXAM DONE FOR REMOTE FACILITY
34 I (CODE=3) D
35 .S OWNPTR=+$P($G(^DVB(396.3,REQPTR,0)),"^",22)
36 .S OWNER=$P($G(^DIC(4.2,OWNPTR,0)),"^",1)
37 .S:('OWNPTR) OWNER="UNKNOWN"
38 ;GET EXAM DATE & TYPE
39 S NODE=$G(^DVB(396.4,PTR,0))
40 S TYPEPTR=+$P(NODE,"^",3)
41 S FMDATE=+$P(NODE,"^",6)
42 ;CALCULATE INVERSE EXAM DATE
43 S INVDATE=9999999-FMDATE
44 ;PUT INFO INTO GLOBAL
45 S @ARR@(INVDATE,TYPEPTR,1)=LOCATION_"^"_OWNER_"^"_OUTDOM
46 Q
47OUT2(PTR,ARR) ;SET NODE TWO OF OUTPUT
48 ;INPUT : PTR - Pointer to 2507 EXAM file (#396.4)
49 ; ARR - Where to place output (full global reference)
50 ;OUTPUT : None
51 ; See HSCP^DVBCHS0() for format of output array
52 ;NOTES : All input is assumed to exist (no error checking)
53 ;
54 N NODE,CODE,TYPEPTR,FMDATE,INVDATE
55 N STATUS,APPRVBY,APPRVDTE,REQPTR
56 ;DETERMINE CODE (BASED ON TRANSFER OUT/IN DATES)
57 S NODE=$G(^DVB(396.4,PTR,"TRAN"))
58 ;DONE AT LOCAL FACILITY
59 S CODE=1
60 ;DONE AT REMOTE FACILITY
61 S:($P(NODE,"^",1)'="") CODE=2
62 ;DONE AT LOCAL FACILITY FOR REMOTE FACILITY
63 S:($P(NODE,"^",4)'="") CODE=3
64 ;GET INFO FROM REQUEST
65 S REQPTR=+$P($G(^DVB(396.4,PTR,0)),"^",2)
66 ;GET APPROVAL INFO
67 S NODE=$G(^DVB(396.3,REQPTR,1))
68 S APPRVBY=$P(NODE,"^",5)
69 S APPRVDTE=+$P(NODE,"^",6)
70 ;DETERMINE STATUS
71 S TMP=$P($G(^DVB(396.3,REQPTR,0)),"^",18)
72 S STATUS="UNKNOWN"
73 S:(TMP="N") STATUS="NEW",APPRVBY="N/A"
74 S:(TMP="P") STATUS="PENDING, REPORTED",APPRVBY="N/A"
75 S:(TMP="S") STATUS="PENDING SCHEDULED",APPRVBY="N/A"
76 S:(TMP="R") STATUS="RELEASED TO RO, NOT PRINTED"
77 S:(TMP="C") STATUS="COMPLETED, PRINTED BY RO"
78 S:(TMP="X") STATUS="CANCELLED BY MAS",APPRVBY="N/A"
79 S:(TMP="RX") STATUS="CANCELLED BY RO",APPRVBY="N/A"
80 S:(TMP="T") STATUS="TRANSCRIBED",APPRVBY="N/A"
81 S:(TMP="NT") STATUS="NEW, TRANSFERRED IN",APPRVBY="N/A"
82 S:(TMP="CT") STATUS="COMPLETED, TRANSFERRED OUT"
83 S:(STATUS="UNKNOWN") APPRVBY="N/A"
84 ;GET EXAM DATE & TYPE
85 S NODE=$G(^DVB(396.4,PTR,0))
86 S TYPEPTR=+$P(NODE,"^",3)
87 S FMDATE=+$P(NODE,"^",6)
88 ;CALCULATE INVERSE EXAM DATE
89 S INVDATE=9999999-FMDATE
90 ;PUT INFO INTO GLOBAL
91 S @ARR@(INVDATE,TYPEPTR,2)=STATUS_"^"_APPRVBY_"^"_APPRVDTE
92 Q
Note: See TracBrowser for help on using the repository browser.