source: WorldVistAEHR/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCYP15.m@ 846

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

initial load of WorldVistAEHR
File size: 6.0 KB
RevLine 
[613]1GMRCYP15 ;SLC/JFR-- CONVERT PROCEDURES FROM 101 TO 123.3; 3/08/01 22:00
2 ;;3.0;CONSULT/REQUEST TRACKING;**15**;DEC 27, 1997
3 ;
4 ; This routine invokes IA #3169,#3170
5 ;
6EN ;called from post-install of GMRC*3*15
7 N GMRCPROG,XPDIDTOT
8 S GMRCPROG=$$GET^XPAR("PKG.CONSULT/REQUEST TRACKING","GMRC PROCEDURE CONVERSION",1)
9 I GMRCPROG=3 D BMES^XPDUTL("Procedure conversion complete") Q
10 I GMRCPROG<2 D
11 . D CVTOIS
12 . D EN^XPAR("PKG.CONSULT/REQUEST TRACKING","GMRC PROCEDURE CONVERSION",1,2)
13 D CVT123
14 D EN^XPAR("PKG.CONSULT/REQUEST TRACKING","GMRC PROCEDURE CONVERSION",1,3)
15 D MAIL
16 Q
17 ;
18CVTOIS ;loop through ORD ITEMS in S.PROC x-ref
19 N ITMNM,ORDITM,PROC,PROTID,GMRCID
20 D EN^XPAR("PKG.CONSULT/REQUEST TRACKING","GMRC PROCEDURE CONVERSION",1,1)
21 D BMES^XPDUTL("Converting Orderable Items")
22 S ITMNM="",^XTMP("GMRCCVPR",0)=$$FMADD^XLFDT($$NOW^XLFDT,14)
23 S $P(^XTMP("GMRCCVPR",0),U,2)=$$NOW^XLFDT
24 S $P(^XTMP("GMRCCVPR",0),U,3)="Conversion of GMRC Procedure ord. items"
25 F S ITMNM=$O(^ORD(101.43,"S.PROC",ITMNM)) Q:ITMNM="" D
26 . S ORDITM=0
27 . F S ORDITM=$O(^ORD(101.43,"S.PROC",ITMNM,ORDITM)) Q:'ORDITM D
28 .. I '$$OKTOGO(ITMNM,ORDITM) Q
29 .. S PROC=$$CNVT(ORDITM) I '+PROC Q
30 .. S PROTID=$P(^ORD(101.43,ORDITM,0),U,2)
31 .. S GMRCID=$$ID^ORDD43(PROTID,PROC_";99PRC")
32 .. S ^XTMP("GMRCCVPR",ORDITM)=PROC_U_$S($G(GMRCID):$G(PROTID),1:"ERROR")
33 .. Q
34 . Q
35 Q
36OKTOGO(NAME,NUM) ;OK to move from 101.43 to 123.3?
37 I $D(^XTMP("GMRCCVPR",NUM)) Q 0 ;already converted
38 I +$G(^ORD(101.43,"S.PROC",NAME,NUM)),$P(^ORD(101.43,NUM,0),U)'=NAME Q 0 ;synonym only
39 I '+$P(^ORD(101.43,NUM,0),U,2) Q 0 ;no protocol
40 I $P(^ORD(101.43,NUM,0),U,2)[";99PRC" Q 0 ;new ID already
41 Q 1
42CNVT(IEN) ;move it from 101.43 to 123.3
43 N DIC,DIE,DR,DA,X,Y,DTOUT,DUOUT,DLAYGO,ORD0,GMRCPROC,NEW
44 S DIC="^GMR(123.3,",DIC(0)="XL",DLAYGO=123.3
45 S ORD0=^ORD(101.43,IEN,0)
46 S X=$$UP^XLFSTR($P(ORD0,U))
47 D ^DIC I Y'>0 Q 0
48 S DIE=DIC,DA=+Y,GMRCPROC=+Y,NEW=$P(Y,U,3)
49 I +NEW S DR=".06_////"_+$P(ORD0,U,2)
50 I +$G(^ORD(101.43,IEN,.1)) S DR=$S($D(DR):DR_";",1:"")_".02///1"
51 I $D(DR) D ^DIE
52 D SYN(IEN,GMRCPROC)
53 D SERVS(GMRCPROC,+$P(ORD0,U,2))
54 Q +GMRCPROC
55SYN(OITM,PROC) ;get any synonyms from 101.43 and update 123.3
56 N DR,DIC,X,Y,DTOUT,SYN,DA
57 S SYN=0
58 F S SYN=$O(^ORD(101.43,OITM,2,SYN)) Q:'SYN I $L($G(^(SYN,0))) D
59 . S DA(1)=PROC,DIC="^GMR(123.3,"_DA(1)_",1,"
60 . S DIC(0)="XL",DIC("P")=$P(^DD(123.3,1,0),U,2)
61 . S X=$P(^ORD(101.43,OITM,2,SYN,0),U)
62 . D ^DIC
63 Q
64SERVS(PROC,PROT) ;get related servisces from 123.5 and move to 123.3
65 N DR,DIC,X,Y,DTOUT,SERV,DA
66 S SERV=0
67 F S SERV=$O(^GMR(123.5,"APR",PROT,SERV)) Q:'SERV D
68 . S DA(1)=PROC,DIC="^GMR(123.3,"_DA(1)_",2,",X=$P(^GMR(123.5,SERV,0),U)
69 . S DIC(0)="XL",DIC("P")=$P(^DD(123.3,2,0),U,2)
70 . D ^DIC
71 Q
72CVTPRO(PROT) ;move protocol entry to 123.3
73 N DIC,DIE,DR,DA,X,Y,DLAYGO,NAME,PROC
74 I '$D(^ORD(101,PROT,0)) Q 1 ;no protocol there
75 S NAME=$P(^ORD(101,PROT,0),U,2) I '$L(NAME) Q 1 ;no name
76 I $G(^ORD(101,PROT,20))'["GMRCEN=""R""" Q "" ;consult type
77 S DIC="^GMR(123.3,",DIC(0)="LX",X=$$UP^XLFSTR(NAME)
78 D ^DIC I +Y<0 Q 1
79 I '$P(Y,U,3) Q +Y
80 S (PROC,DA)=+Y
81 S DIE=DIC,DR=".02///1;.06///^S X=PROT" D ^DIE
82 Q +PROC
83 ;
84 ;
85CVT123 ; loop through file 123 and convert field #4 and #13
86 N IEN,PROC,GMRCCSLT,GMRCPRC,GMR0
87 D EN^XPAR("PKG.CONSULT/REQUEST TRACKING","GMRC PROCEDURE CONVERSION",1,2)
88 D BMES^XPDUTL("Converting REQUEST/CONSULTATION data")
89 S XPDIDTOT=$P(^GMR(123,0),U,4) I XPDIDTOT<100 K XPDIDTOT
90 S GMRCCSLT=$$FIND1^DIC(101,,"QX","GMRCOR CONSULT")
91 S GMRCPRC=$$FIND1^DIC(101,,"QX","GMRCOR REQUEST")
92 S IEN=0 F S IEN=$O(^GMR(123,IEN)) Q:'IEN D
93 . I $D(XPDIDTOT) I '(IEN#(XPDIDTOT\20)) D UPDATE^XPDID(IEN)
94 . Q:'$D(^GMR(123,IEN,0))
95 . S GMR0=^GMR(123,IEN,0)
96 . I $P(GMR0,U,17)'="C"&($P(GMR0,U,17)'="P") D ;not converted yet
97 .. I $P(GMR0,U,8)["ORD(101" D
98 ... N NWPROC
99 ... S NWPROC=$$CVT4(+$P(^GMR(123,IEN,0),U,8))
100 ... I +NWPROC=1 S ^XTMP("GMRCCVPR","UNK",IEN)=$P(GMR0,U,8)
101 ... S $P(^GMR(123,IEN,0),U,8)=NWPROC
102 .. S $P(^GMR(123,IEN,0),U,17)=$S(+$P(^GMR(123,IEN,0),U,8):"P",1:"C")
103 .. Q
104 . Q
105 Q
106CVT4(PCL) ;convert field 4 from 101 to 123.3
107 ; PCL = pointer to file 101
108 N PROC
109 S PROC=$O(^GMR(123.3,"AP",PCL,0))
110 I 'PROC S PROC=$$CVTPRO(PCL)
111 Q $S(+PROC:PROC_";GMR(123.3,",1:"")
112 ;
113 ;
114MAIL ; check conversion and send mail to installer
115 D CK10143
116 D CHK123
117 I '$D(^TMP("GMRCP15",$J)) D
118 . S ^TMP("GMRCP15",$J,1,0)="No problems found with the conversion."
119 S ^TMP("GMRCP15",$J,0)=""
120 N GMRCSB,GMRCTO,GMRCTXT,GMRCMSG
121 S GMRCSB="GMRC*3*15 Post-install conversion report"
122 S GMRCTXT=$NA(^TMP("GMRCP15",$J))
123 S GMRCTO(DUZ)=""
124 D SENDMSG^XMXAPI(DUZ,GMRCSB,GMRCTXT,.GMRCTO,,.GMRCMSG)
125 I $G(GMRCMSG) D
126 . D BMES^XPDUTL("Mail message "_GMRCMSG_" sent to installer")
127 . N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,ZTIO,GMRCDUZ
128 . S GMRCDUZ=DUZ
129 . S ZTSAVE("GMRCMSG")="",ZTSAVE("GMRCDUZ")=""
130 . S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,5),ZTRTN="NWMAL^GMRCYP15"
131 . S ZTIO="",ZTDESC="New GMRC*3*15 post-install message"
132 . D ^%ZTLOAD
133 K ^TMP("GMRCP15",$J)
134 Q
135 ;
136NWMAL ;make post-install message new
137 S ZTREQ="@"
138 I $G(GMRCMSG),$G(GMRCDUZ) D
139 . D MAKENEW^XMXUTIL(DUZ,1,GMRCMSG,1)
140 Q
141 ;
142CHK123 ;loop 123 and check field 4 to make sure it's converted
143 N GMRCIEN,PROC,NEXT
144 S GMRCIEN=0
145 I $D(^TMP("GMRCP15",$J)) D
146 . S ^TMP("GMRCP15",$J,$O(^TMP("GMRCP15",$J," "),-1)+1,0)=""
147 F S GMRCIEN=$O(^GMR(123,GMRCIEN)) Q:'GMRCIEN D
148 . I $D(XPDIDTOT) D:'(GMRCIEN#(XPDIDTOT\20)) UPDATE^XPDID(GMRCIEN)
149 . I '$D(XPDNM) W:'(GMRCIEN#78000) !,"Working",!
150 . I '$D(XPDNM) W:'(GMRCIEN#1000) "."
151 . S PROC=$P($G(^GMR(123,GMRCIEN,0)),U,8) I '$L(PROC) Q
152 . I PROC["ORD(101"!(PROC="1;GMR(123.3,") D
153 .. S NEXT=$O(^TMP("GMRCP15",$J," "),-1)+1
154 .. S ^TMP("GMRCP15",$J,NEXT,0)="File 123 ien "_GMRCIEN_" points to "_PROC
155 . Q
156 Q
157CK10143 ;loop thru S.PROC x-ref in 101.43 and check for complete conv
158 N OINAME,OINUM,NEXT
159 D BMES^XPDUTL("Checking converted data")
160 S OINAME=""
161 F S OINAME=$O(^ORD(101.43,"S.PROC",OINAME)) Q:OINAME="" D
162 . S OINUM=$O(^ORD(101.43,"S.PROC",OINAME,0)) Q:'OINUM
163 . I +$G(^ORD(101.43,"S.PROC",OINAME,OINUM)) Q ;syn only
164 . I $P($G(^ORD(101.43,OINUM,0)),U,2)'["99PRC" D
165 .. S NEXT=$O(^TMP("GMRCP15",$J," "),-1)+1
166 .. S ^TMP("GMRCP15",$J,NEXT,0)="File 101.43 ien "_OINUM_" has a bad ID"
167 . Q
168 Q
Note: See TracBrowser for help on using the repository browser.