Changeset 186 for ccr/trunk/p/CCRMEDS.m
- Timestamp:
- Oct 6, 2008, 11:46:35 AM (16 years ago)
- File:
-
- 1 edited
-
ccr/trunk/p/CCRMEDS.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/trunk/p/CCRMEDS.m
r185 r186 1 1 CCRMEDS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR MEDICATIONS ;07/23/08 14:33 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 2 ;;0.1;CCDCCR;;JUL 16,2008; 3 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 ;General Public License See attached copy of the License. 5 ; 6 ;This program is free software; you can redistribute it and/or modify 7 ;it under the terms of the GNU General Public License as published by 8 ;the Free Software Foundation; either version 2 of the License, or 9 ;(at your option) any later version. 10 ; 11 ;This program is distributed in the hope that it will be useful, 12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ;GNU General Public License for more details. 15 ; 16 ;You should have received a copy of the GNU General Public License along 17 ;with this program; if not, write to the Free Software Foundation, Inc., 18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 19 ; 20 W "NO ENTRY FROM TOP",! 21 Q 22 ; 23 23 EXTRACT(MEDXML,DFN,MEDOUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 24 ; 25 ; MEDXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 26 ; IMEDXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE 27 ; 28 N HASOP S HASOP=0 ; FLAG FOR HAS OUTPATIENT MEDS 29 N MEDCNT S MEDCNT=0 ; COUNT FOR MEDS ALREADY PROCESSED 30 ; OUTPATIENT ACTIVE MEDS ARE PROCESSED IN EXTRACT^CCRMEDS1 31 ; OUTPATIENT PENDING MEDS IN EXTRACT^CCRMEDS2 32 ; NON-VA MEDS IN EXTRACT^CCRMEDS3 33 ; INPATIENT MEDS IN EXTRACT^CCRMEDS4 34 ; ALL OTHERS HERE 35 D EXTRACT^CCRMEDS1(MEDXML,DFN,MEDOUTXML) ; FIRST EXTRACT OUTPATIENT MEDS 36 I @MEDOUTXML@(0)>0 D ; CCRMEDS FOUND ACTIVE OP MEDS 37 . S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML 38 . S MEDCNT=@MEDOUTXML@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP 39 . W "HAS ACTIVE OP MEDS",! 40 N PENDINGXML,MEDPENDING 41 S PENDINGXML="MEDPENDING" ;NAME FOR ARRAY 42 D EXTRACT^CCRMEDS2(MEDXML,DFN,PENDINGXML) ; FIRST EXTRACT OUTPATIENT MEDS 43 I @PENDINGXML@(0)>0 D ; CCRMEDS FOUND PENDING OP MEDS 44 . S HASOP=1 ; SET FLAG TO KNOW HOW TO ADD XML 45 . I @MEDOUTXML@(0)>0 D ; IF WE NEED TO COMBINE MEDS 46 . . D INSINNER^GPLXPATH(MEDOUTXML,PENDINGXML) ;ADD PENDING TO ACTIVE 47 . E D CP^GPLXPATH(PENDINGXML,MEDOUTXML) ; NO ACTIVE MEDS, JUST COPY 48 . S MEDCNT=@MEDOUTXML@(0) ; SAVE COUNT TO KNOW HOW TO ADD TO MAP 49 . W "HAS OP PENDING MEDS",! 50 N MEDRSLT,I,J,K,MEDPTMP,X,MEDVMAP,TBUF 51 D ACTIVE^ORWPS(.MEDRSLT,DFN) 52 I '$D(MEDRSLT(1)) D ; NO MEDS FOR THIS PATIENT, EXIT 53 . I DEBUG W "MEDICATIONS RPC RETURNED NULL",! 54 . S @MEDOUTXML@(0)=0 55 . Q 56 ; I DEBUG ZWR MEDRSLT 57 M GPLMEDS=MEDRSLT 58 S MEDTVMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) 59 S MEDTARYTMP=$NA(^TMP("GPLCCR",$J,"MEDARYTMP")) 60 I 'HASOP K @MEDTVMAP,@MEDTARYTMP 61 ; FIRST GO THROUGH MEDRSLT ARRAY AND COUNT MEDS AND LINES IN MEDS 62 ; ZA(0) IS TOTAL NUMBER OF MEDS ZA(ZI) IS LINES IN MED ZI 63 N ZA,ZI,ZJ,ZK,ZN S (ZI,ZJ,ZK,ZN)=0 ; ZI IS MED NUMBER, ZJ IS LINE IN MED 64 ; ZK IS THE NUMBER OF LINES IN A MED AND ZN IS COUNTER THROUGH LINES 65 S ZA(0)=0 ; ZA IS ARRAY OF MED LINE COUNTS 66 F ZJ=1:1 Q:'$D(MEDRSLT(ZJ)) D ; COUNT THE MEDS AND LINES 67 . I MEDRSLT(ZJ)?1"~".E D ; FOUND NEW MED 68 . . S ZI=ZI+1 ; INCREMENT MED COUNT 69 . . S ZA(0)=ZI ; NEW TOTAL FOR MEDS 70 . . S ZA(ZI)=ZJ_U_1 ; EACH ZA(X) IS Y^Z WHERE Y IS START LINE AND Z IS COUNT 71 . E D ; FOR EVERY LINE NOT A FIRST LINE IN MED 72 . . S ZK=$P(ZA(ZI),U,2)+1 ; INCREMENT LINE COUNT FOR CURRENT MED 73 . . S $P(ZA(ZI),U,2)=ZK ; AND STORE IT IN ARRAY 74 ;ZWR ZA 75 S @MEDTVMAP@(0)=ZA(0) ; SAVE NUMBER OF MEDS 76 F ZI=1:1:ZA(0) D ; FOR EACH MED 77 . I DEBUG W "ZI IS ",ZI,! 78 . S MEDVMAP=$NA(@MEDTVMAP@(ZI+MEDCNT)) ; START PAST OP ACTIVE MEDS 79 . K @MEDVMAP 80 . I DEBUG W "VMAP= ",MEDVMAP,! 81 . S ZJ=$P(ZA(ZI),U,1) ; INDEX OF FIRST LINE OF MED IN MEDRSLT 82 . S MEDPTMP=MEDRSLT(ZJ) ; PULL OUT FIRST LINE OF MED 83 . I $P(MEDPTMP,U,1)?1"~OP" Q ; SKIP OP ACTIVE AND PENDING 84 . S @MEDVMAP@("MEDOBJECTID")="MED"_(ZI+MEDCNT) ; UNIQUE OBJID FOR MEDS 85 . I $P(MEDPTMP,"^",11)="" S @MEDVMAP@("MEDISSUEDATETXT")="" 86 . E S @MEDVMAP@("MEDISSUEDATETXT")=$$FMDTOUTC^CCRUTIL($P(MEDPTMP,"^",11),"DT") ; GETS LAST FILL DATE 87 . S @MEDVMAP@("MEDISSUEDATE")="" 88 . S @MEDVMAP@("MEDLASTFILLDATETXT")="" 89 . S @MEDVMAP@("MEDLASTFILLDATE")="" 90 . S @MEDVMAP@("MEDRXNOTXT")="" 91 . S @MEDVMAP@("MEDRXNO")="" 92 . S @MEDVMAP@("MEDDETAILUNADORNED")="" 93 . S @MEDVMAP@("MEDCONCVALUE")="" 94 . S @MEDVMAP@("MEDCONCUNIT")="" 95 . S @MEDVMAP@("MEDSIZETEXT")="" 96 . S @MEDVMAP@("MEDDOSEINDICATOR")="" 97 . S @MEDVMAP@("MEDDELIVERYMETHOD")="" 98 . S @MEDVMAP@("MEDRATEVALUE")="" 99 . S @MEDVMAP@("MEDRATEUNIT")="" 100 . S @MEDVMAP@("MEDVEHICLETEXT")="" 101 . S @MEDVMAP@("MEDFREQUENCYUNIT")="" 102 . S @MEDVMAP@("MEDINTERVALVALUE")="" 103 . S @MEDVMAP@("MEDINTERVALUNIT")="" 104 . S @MEDVMAP@("MEDPRNFLAG")="" 105 . S @MEDVMAP@("MEDPROBLEMOBJECTID")="" 106 . S @MEDVMAP@("MEDPROBLEMTYPETXT")="" 107 . S @MEDVMAP@("MEDPROBLEMDESCRIPTION")="" 108 . S @MEDVMAP@("MEDPROBLEMCODEVALUE")="" 109 . S @MEDVMAP@("MEDPROBLEMCODINGSYSTEM")="" 110 . S @MEDVMAP@("MEDPROBLEMCODINGVERSION")="" 111 . S @MEDVMAP@("MEDPROBLEMSOURCEACTORID")="" 112 . S @MEDVMAP@("MEDSTOPINDICATOR")="" 113 . S @MEDVMAP@("MEDDIRSEQ")="" 114 . S @MEDVMAP@("MEDMULDIRMOD")="" 115 . S @MEDVMAP@("MEDPTINSTRUCTIONS")="" 116 . S @MEDVMAP@("MEDFULLFILLMENTINSTRUCTIONS")="" 117 . S @MEDVMAP@("MEDDATETIMEAGE")="" 118 . S @MEDVMAP@("MEDDATETIMEAGEUNITS")="" 119 . S @MEDVMAP@("MEDTYPETEXT")="Medication" 120 . S @MEDVMAP@("MEDSTATUSTEXT")=$P(MEDPTMP,"^",10) ; STATUS FROM RPC 121 . S @MEDVMAP@("MEDSOURCEACTORID")="ACTORSYSTEM_1" 122 . S @MEDVMAP@("MEDPRODUCTNAMETEXT")=$P(MEDPTMP,"^",3) 123 . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")="" ; DEFAULT VALUE 124 . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" 125 . S @MEDVMAP@("MEDPRODUCTNAMECODEVERSION")="" 126 . I $P(MEDPTMP,U,1)?1"~OP" D ; IS OUTPATIENT, MIGHT HAVE CODE 127 . . I $P(MEDPTMP,"^",10)="ACTIVE" D ; ONLY ACTIVE MEDS HAVE CODES 128 . . . N RXIEN ; IEN TO RX, EXAMPLE "~OP^13R;O^IBUPROFEN 400MG^" 13 IS IT 129 . . . S RXIEN=$$DIGITS($P($P(MEDPTMP,U,2),";",1)) ; GET JUST LEADING DIGITS 130 . . . I DEBUG W "RXIEN=",RXIEN,! ; 131 . . . D RX^PSO52API(DFN,"MEDCODE",RXIEN) ; EXTRACT THE RX RECORD TO ^TMP 132 . . . I $D(^TMP($J,"MEDCODE",DFN,RXIEN,27)) D ; IF SUCCESS 133 . . . . S @MEDVMAP@("MEDPRODUCTNAMECODEVALUE")=^TMP($J,"MEDCODE",DFN,RXIEN,27) 134 . . . . S @MEDVMAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="NDC" 135 . S @MEDVMAP@("MEDBRANDNAMETEXT")="" 136 . S @MEDVMAP@("MEDBRANDNAMECODEVALUE")="" 137 . S @MEDVMAP@("MEDBRANDNAMECODINGSYSTEM")="" 138 . S @MEDVMAP@("MEDBRANDNAMECODEVERSION")="" 139 . S @MEDVMAP@("MEDSTRENGTHVALUE")="" 140 . S @MEDVMAP@("MEDSTRENGTHUNIT")="" 141 . S @MEDVMAP@("MEDFORMTEXT")="" 142 . S @MEDVMAP@("MEDQUANTITYVALUE")="" 143 . S @MEDVMAP@("MEDQUANTITYUNIT")="" 144 . S @MEDVMAP@("MEDRFNO")="" 145 . S ZK=$P(ZA(ZI),U,2) ; NUMBER OF LINES IN MED 146 . I ZK>1 D ; MORE THAN ONE LINE IN MED 147 . . S @MEDVMAP@("MEDDESCRIPTIONTEXT")=$P(MEDRSLT(ZJ+1)," *",2) 148 . I ZK>2 D ; THIRD THROUGH 2+N LINES OF MED ARE INSTRUCTIONS 149 . . N TMPTXT S TMPTXT="" ; BUILD UP INSTRUCTION LINE 150 . . F ZN=2:1:ZK-1 D ; REMAINING LINES IN EACH MED 151 . . . I MEDRSLT(ZJ+ZN)]"\ Sig: " D ; REMOVE THIS MARKUP 152 . . . . S TMPTXT=TMPTXT_$P(MEDRSLT(ZJ+ZN),"\ Sig: ",2)_" " ; APPEND 2 TMPTXT 153 . . . E S TMPTXT=TMPTXT_MEDRSLT(ZJ+ZN)_" " ; SEPARATE LINES WITH SPACE 154 . . S @MEDVMAP@("MEDDIRECTIONDESCRIPTIONTEXT")=TMPTXT ; CP TO MAP VAR 155 . S @MEDVMAP@("MEDDOSEVALUE")="" 156 . S @MEDVMAP@("MEDDOSEUNIT")="" 157 . S @MEDVMAP@("MEDFREQUENCYVALUE")="" 158 . S @MEDVMAP@("MEDDURATIONVALUE")="" 159 . S @MEDVMAP@("MEDDURATIONUNIT")="" 160 . S @MEDVMAP@("MEDDIRECTIONROUTETEXT")="" 161 . S @MEDVMAP@("MEDDIRECTIONFREQUENCYVALUE")="" 162 . S MEDARYTMP=$NA(@MEDTARYTMP@(ZI)) 163 . K @MEDARYTMP 164 . D MAP^GPLXPATH(MEDXML,MEDVMAP,MEDARYTMP) 165 . I ZI=1&('HASOP) D ; FIRST ONE IS JUST A COPY MAKE SURE OP IS NOT THERE 166 . . ; W "FIRST ONE",! 167 . . D CP^GPLXPATH(MEDARYTMP,MEDOUTXML) 168 . E D ; AFTER THE FIRST OR IF THERE ARE OP, INSERT INNER XML 169 . . D INSINNER^GPLXPATH(MEDOUTXML,MEDARYTMP) 170 N MEDTMP,MEDI 171 D MISSING^GPLXPATH(MEDOUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 172 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 173 . W "MEDICATION MISSING ",! 174 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 175 Q 176 ; 177 177 DIGITS(INSTR) ; RETURN JUST THE LEADING DIGITS OF THE STRING 178 179 180 181 182 178 ; EXAMPLE: $$DIGITS("13R") RETURNS 13 179 N ALPHA ; CONTANT TO HOLD ALL ALPHA CHARACTERS 180 S ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" ; ALPHAS 181 Q $TR(INSTR,ALPHA) ; LEAVE ONLY THE DIGITS 182 ;
Note:
See TracChangeset
for help on using the changeset viewer.
