source: FOIAVistA/trunk/r/MEDICINE-MC/MCORMN.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 5.2 KB
Line 
1MCORMN ;WISC/DCB-Front-end for Health Summary ;4/26/04 11:54
2 ;;1.0;CLINICAL PROCEDURES;**5,13**;Apr 01, 2004;Build 19
3 ; Reference IA #1236 for Medicine and Health Summary interface.
4 ; #3778 for Medicine and Health Summary interface for RDV
5 ; #10070 for XMD API call.
6 ; #10064 for XM call.
7 ; #10090 DIC(4) Read Access.
8 ; #10106 for HLFNC calls.
9 ; #10113 for Access to ^XMB(3.9,#,2)
10HL7(MESSNUMB) ;This is the HL7 entry point for queries
11 N MSH,TEMP,ORD,ST,MSTR,BDATE,EDATE,OCC,PROC,PATID,MCTDEC,XMZ,MCLINE
12 N QDT,QFC,QP,QID,RAP,GNODE,ATYPE
13 Q:+MESSNUMB=0 0
14 S GNODE="^XMB(3.9,"_MESSNUMB_",2)"
15 S MSH=$G(@GNODE@(1,0)) I MSH="" D ERROR Q 0
16 S MSTR=$E(MSH,4,9) D SLIP^MCORMN0(MSTR)
17 S QRD=$G(@GNODE@(2,0)) I QRD="" D ERROR Q 0
18 S QFC=$P(QRD,ST(1),3) I QFC'="R" D ERROR Q 0
19 S QLR=$P(QRD,ST(1),8),OCC=$P(QLR,ST(2),2),ATYPE=$P(QLR,ST(2),1)
20 S PATID=+$P(QRD,ST(1),9)
21 I '$D(^MCAR(690,"AC",PATID)) D ERROR Q ""
22 S PROC=$P(QRD,ST(1),11)
23 S TEMP=$P(QRD,ST(1),12) S BDATE=$P(TEMP,ST(2),1),EDATE=$P(TEMP,ST(2),2)
24 S BDATE=$$FMDATE^HLFNC(BDATE),EDATE=$$FMDATE^HLFNC(EDATE)
25 S RAP=$P(MSH,ST(1),3)
26 S MCTDEC="^TMP(""MCAR1"",$J)",GLOBAL=1
27 D HSUM(RAP,PATID,BDATE,EDATE,OCC,PROC,MSTR,MCTDEC,.GLOBAL,ATYPE)
28 I GLOBAL=0 S ^TMP("MCAR1",$J,1)="" Q 0
29 I GLOBAL'=0 D
30 .S XMSUB="Medicine Response",XMDUN="Medicine",XMDUZ=.5
31 .S XMTEXT="^TMP(""MCAR1"",$J,",XMY("G.MC MESSAGING SERVER")=""
32 .;S XMY(DUZ)=""
33 .D ^XMD
34 .S GLOBAL=+$G(XMZ)
35 D KILL^XM
36 K ^TMP("MCAR1",$J)
37 Q GLOBAL
38ERROR ;HL7 Messaging Error
39 D KILL^XM Q
40SERVER ;A do nothing routine
41 Q
42HSUM(RAP,PATID,BDATE,EDATE,OCC,PE,MSTR,MCTDEC,GLOBAL,ATYPE) ;Sending Message Builder
43 N LOC,REC,RNF,SNF,SAP,MST,PCI,VID,MCDFN,TMP,ENDDATE,BEGDATE,MCIMAGE
44 N LOOP,DFN,COUNT,MCPROC,MCFILE,PREC,SENDATE,FILE,MCREC,MCDEST
45 N MCER,MCERR,MCVAL,TEMP,WH,S5
46 I +PATID'=PATID S GLOBAL=0 Q
47 I '$D(^MCAR(690,"AC",PATID))&('$D(^MDD(702,"B",PATID))) S GLOBAL=0 Q
48 I PE'="" D
49 .S S5=+$O(^MCAR(697.2,"B",PE,0))
50 .S S5=$P($G(^MCAR(697.2,S5,0)),U,2)
51 .I S5="" S PE="" K S5
52 S MCVAL=DUZ(2),REC=$$FIND1^DIC(4,"","X",MCVAL,"D","","MCER")
53 S LOC=$S(+REC:$$GET1^DIQ(4,+REC_",",.01),1:"")
54 S (RNF,SNF)=LOC
55 S SAP="Medicine",MST="HS",PCI="P"
56 S VID=$P($T(+2),";",3),MCDFN=PATID,MCLINE=0
57 S:EDATE="" EDATE=9999999.9999
58 S:BDATE="" BDATE=0
59 S:+OCC=0 OCC=999999
60 I EDATE<BDATE S TEMP=EDATE,EDATE=BDATE,BDATE=TEMP
61 S ENDDATE=(9999999.9999-EDATE)-.00001
62 S BEGDATE=(9999999.9999-BDATE)+.00001
63 S LOOP=ENDDATE,COUNT=0
64 N L,LL,LL1,K,M,PE,REC,S1,S2,S4,S6
65 N MCARCODE,MCARFILE,MCARPSUM,MCARSUM,MCESKEY,MCESON,MCSUP,MCESSEC
66 S MCIMAGE=""
67 K ^TMP("MCAR",$J)
68 S DFN=PATID,WH="P" D ^MCARPS1
69PROCN ;
70 N MCRESULT,MDHOLDR,MCROU
71 I $$PATCH^XPDUTL("MD*1.0*2")!('$$FIND1^DIC(9.4,"","MX","MEDICINE")) D
72 .S MDRDV=1 K ^TMP("MDPLST",$J)
73 .S MCRESULT=$NA(^TMP("MDPLST",$J)) N MCLP,MCLP1,MCXG
74 .S MCROU="D GET702^MDPS3(.MCRESULT,PATID,"""",BDATE,EDATE,OCC)"
75 .X MCROU
76 .S MCLP="" F S MCLP=$O(^TMP("MDPLST",$J,MCLP)) Q:MCLP="" S MCLP1="" F S MCLP1=$O(^TMP("MDPLST",$J,MCLP,MCLP1)) Q:MCLP1="" S MCXG=$G(^(MCLP1)) D
77 ..S:$G(^TMP("MCAR",$J,MCLP,MCLP1))="" ^TMP("MCAR",$J,MCLP,MCLP1)=MCXG
78 .K ^TMP("MDPLST",$J)
79 S MCPROC="",COUNT=0 N MCG
80 F S MCPROC=$O(^TMP("MCAR",$J,MCPROC)) Q:MCPROC="" D
81 .S MCDTIME=ENDDATE
82 .F S MCDTIME=$O(^TMP("MCAR",$J,MCPROC,MCDTIME)) Q:MCDTIME="" Q:COUNT'<OCC Q:MCDTIME>BEGDATE S MCG=$G(^(MCDTIME)) D
83 ..S MCREC=$P(MCG,U,2) Q:+MCREC=0
84 ..S MCDEST=MCTDEC,SENDATE=9999999.9999-MCDTIME,MDHOLDR=MCPROC
85 ..I +$G(BDATE) Q:SENDATE<+$G(BDATE)
86 ..I +$G(EDATE) Q:SENDATE>+$G(EDATE)
87 ..I $P(MCG,U,4)["MDPS1" S MCARGDA=+$P(MCG,U,2) Q:'MCARGDA D PR690 S COUNT=COUNT+1,MCPROC=MDHOLDR Q
88 ..I $P(MCG,U,4)["MDPS4" S MCARGDA=+$P(MCG,U,2) Q:'MCARGDA D PR690 S COUNT=COUNT+1,MCPROC=MDHOLDR Q
89 ..S PREC=$O(^MCAR(697.2,"B",MCPROC,"")) Q:PREC=""
90 ..S FILE=$P($G(^MCAR(697.2,PREC,0)),U,2) Q:FILE=""
91 ..S MCFILE=+$P(FILE,"MCAR(",2)
92 ..S MCERR=$$BUILD^MCORMN0(RAP,DFN,SAP,SNF,RNF,MST,PCI,VID,.MCLINE,MSTR,MCDEST,MCPROC,MCFILE,MCREC,SENDATE,ATYPE)
93 ..S:MCERR=0 COUNT=COUNT+1
94 K ^TMP("MCAR",$J),^TMP("MDPTXT",$J),MCPRO,MCARPPS,MCARGRTN,MDT,MDHDR,MDRDV
95 Q
96PR690 ; Set node for CP Reports
97 N HLECH,MCRREC,ST
98 S MCPRO=$P(MCG,U,11),MCARPPS=$P(MCG,U,3,4),MCARGRTN=$P(MCG,U,5),MDT="RD",MDHDR=1
99 S HLECH=$E(MSTR,2,4) D SLIP^MCORMN0(MSTR)
100 D SETNODE(MCDEST,$$MSH^MCORMN01(MCPROC,SAP,SNF,RAP,RNF,MST,PCI,VID))
101 D SETNODE(MCDEST,$$PID^MCORMN01(MCDFN))
102 D SETNODE(MCDEST,$$OBR1(SENDATE,MCPROC,HLECH))
103 D SETNODE(MCDEST,$$OBX1^MCORMN01("W","ST","702~.1~702.1^^DD",1,""))
104 D @MCARPPS S MCRREC=$NA(^TMP("MDPTXT",$J))
105 F S MCRREC=$Q(@MCRREC) Q:MCRREC="" Q:$QS(MCRREC,1)'="MDPTXT" D
106 .D SETNODE(MCTDEC,$G(@MCRREC))
107 D SETNODE(MCDEST,"||")
108 Q
109OBR1(SDATE,MCPROC,HLECH) ; OBX Messaging Line
110 N LOOP,TEMP,TMP,STAT,STR
111 S TMP="OTH"
112 S STAT="COMPLETE"
113 S TEMP=$$CONVERT^MCORMN01("D",SDATE),STR="OBR",$P(STR,ST(1),8)=TEMP
114 S $P(STR,ST(1),16)=TMP,$P(STR,ST(1),26)=STAT
115 Q STR
116SETNODE(NODE,VALUE) ; Set the node with the HL7 message string
117 S MCLINE=MCLINE+1,@NODE@(MCLINE,0)=VALUE
118 Q
119HL1(MCSAP,MCDFN,MCB,MCE,MCOCC,MCTYP) ; Alternate Entry Point for Data View
120 N MSH,TEMP,ORD,ST,MSTR,BDATE,EDATE,OCC,PROC,PATID,MCTDEC,XMZ,MCLINE
121 N QDT,QFC,QP,QID,RAP,GNODE,ATYPE
122 S GLOBAL=1 K ^TMP("MCAR1",$J)
123 D HSUM(MCSAP,MCDFN,MCB,MCE,MCOCC,"","|^~\&|","^TMP(""MCAR1"",$J)",.GLOBAL,MCTYP)
124 I GLOBAL=0 S ^TMP("MCAR1",$J,1,0)=""
125 Q
Note: See TracBrowser for help on using the repository browser.