BWUPRNI ;IHS/ANMC/MWR - UPLOAD: RESULTS FROM CORNING;15-Feb-2003 22:13;PLS
;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CONVERTS NICHOL'S LAB RESULTS FROM FIXED TO VARIABLE, THEN FORMATS
;; REPORTS AND PLACES THEM IN BW PROCEDURE FILE (WP) WITH PATIENTS.
;
;---> * FOR CORNING LAB *
;
;---> CONVERSION AND TRANSFER OF RESULTS FOR * CORNING LAB *.
;---> THIS ROUTINE IS CALLED BY ^BWUPLD. "CVT" CONVERTS CORNING LAB
;---> FIXED LENGTH ASCII TEXT LAB RESULTS ABBREVIATIONS INTO VARIABLE
;---> RECORDS AND ADDS THEM TO THE "BW UPLD RESULTS TEMP (CORNING)"
;---> FILE.
;--->
;---> "TRANS" FORMATS AND TRANSFERS ENTRIES FROM THE "BW UPLD RESULTS
;---> TEMP (CORNING)" FILE INTO THE WP FIELD OF THE "BW PROCEDURE"
;---> FILE. MATCHING IS DONE ON THE BASIS OF THE ACCESSION#, THE "B"
;---> CROSSREFERENCE AND THEN CHART# FOR IHS, SSN# FOR NON-IHS.
;
CVT(LINE,PIECE) ;EP
;---> COVERT FIXED LENGTH INTO "^" DELIMITED VARIABLE LENGTH.
;---> PIECE=1 SAYS PIECE BWLINE WHEN RETURNED TO BWUPLD.
N Y,Z
;---> TRANSLATE ALL "^" INTO "`".
S Y=$TR(LINE,"^","`")
;---> EXTRACT THE ACCESSION#, TRIM OFF ANY TRAILING SPACES.
S Z=$$TRIM($E(Y,106,117))
;---> IF ACCESSION#="", SET ACC#=NICHOL'S REQUISITION#.
S:Z']"" Z=$$TRIM($E(Y,47,62))
;---> EXTRACT THE PATIENT NAME, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,9,32))
;---> EXTRACT THE PATIENT SSN/ACCT#, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,33,46))
;---> EXTRACT THE REQUISITION#, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,47,62))
;---> EXTRACT THE DATE OF BIRTH.
S Z=Z_U_$$TRIM($E(Y,63,72))
;---> EXTRACT THE AGE.
S Z=Z_U_$$TRIM($E(Y,73,76))
;---> EXTRACT THE HOSPITAL ID#/CHART#, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,77,88))
;---> EXTRACT THE REFERRING PHYSICIAN, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,89,105))
;---> EXTRACT THE ACCOUNT#, TRIM TRAILING AND LEADING SPACES.
S Z=Z_U_$$TRIM2($$TRIM($E(Y,1,8)))
;---> EXTRACT THE TEST NAME, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,118,139))
;---> EXTRACT THE COLLECTION DATE.
S Z=Z_U_$$TRIM($E(Y,140,147))
;---> EXTRACT THE LOCATION.
S Z=Z_U_$$TRIM($E(Y,148,153))
;---> EXTRACT THE SPECIMEN SOURCE, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,154,178))
;---> EXTRACT THE SPECIMEN ADEQUACY, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,179,203))
;---> EXTRACT THE GENERAL CATEGORIZATION, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,204,228))
;---> EXTRACT THE DESCRIPTIVE DIAGNOSIS, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,229,253))
;---> EXTRACT THE SQUAMOUS CELLS, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,254,278))
;---> EXTRACT THE GLANDULAR CELLS, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,279,303))
;---> EXTRACT THE REACTIVE/REPAIRATIVE, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,304,328))
;---> EXTRACT THE INFECTION, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,329,353))
;---> EXTRACT THE INFECTION NOTATION, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,354,378))
;---> EXTRACT THE HORMONAL EVALUATION, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,379,403))
;---> EXTRACT THE HORMONAL EVALUATION NOTATION, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,404,428))
;---> EXTRACT THE COMMENT, TRIM TRAILING SPACES.
S Z=Z_U_$$TRIM($E(Y,429,453))
;---> EXTRACT THE REVIEWER, TRIM TRAILING SPACES.
S LINE=Z_U_$$TRIM($E(Y,454,478)),PIECE=1
Q
;
TRIM(X) ;EP
;---> TRIM OFF ANY TRAILING SPACES.
Q:'$D(X) ""
N L S L=$L(X)
F Q:$E(X,L)'=" " S L=L-1
Q $E(X,1,L)
;
TRIM2(X) ;EP
;---> TRIM OFF ANY LEADING SPACES.
Q:'$D(X) ""
N I,L S L=$L(X)
F I=1:1 Q:$E(X,I)'=" "
Q $E(X,I,L)
;
;
TRANS ;EP
;---> * FOR CORNING LAB *
;---> "TRANS" FORMATS AND TRANSFERS ENTRIES FROM THE "BW UPLD RESULTS
;---> TEMP (CORNING)" FILE INTO THE WP FIELD OF THE "BW PROCEDURE"
;---> FILE. MATCHING IS DONE ON THE BASIS OF THE ACCESSION#, THE "B"
;---> CROSSREFERENCE.
;---> BWY WILL EQUAL THE IEN OF THE PROCEDURE, FILE 9002086.1.
;---> BWYY WILL EQUAL THE IEN OF THE LAB RESULT, FILE 9002086.82.
N BWAGENCY,BWDFN,BWHRCN,BWSSN,BWY,BWYY
S (BWMATCH,BWNOMAT)=0,BWTAB=" "
W !?5,"Transferring to ""BW PROCEDURE"" FILE..." H 1
S BWYY=0
F S BWYY=$O(^BWRNI(BWYY)) Q:'BWYY D
.;---> GET ACCESSION#, CHART#, AND SSN# FROM LAB RESULT.
.S BWACC=$P(^BWRNI(BWYY,0),U),BWHRCN=$P(^(0),U,7),BWSSN=$P(^(0),U,3)
.;
.;---> GET IEN OF THE PROCEDURE, FILE 9002086.1, FOR THIS ACCESSION#.
.S BWY=$O(^BWPCD("B",BWACC,0))
.;
.;---> XREF FAILED TO PRODUCE IEN IN PROCEDURE FILE (^BWPCD).
.I BWY="" D NOMATCH^BWUPTRAN(BWYY,1) Q
.I '$D(^BWPCD(BWY,0)) D NOMATCH^BWUPTRAN(BWYY,1) Q
.;
.;---> GET DFN AND AGENCY (IHS, STATE, OR VA).
.S BWDFN=$P(^BWPCD(BWY,0),U,2)
.S BWAGENCY=$$AGENCY^BWUTL5(DUZ(2))
.;
.;---> IF AGENCY IS IHS AND THE CHART# FOR THIS RESULT DOES NOT
.;---> MATCH CHART# FOR THIS PATIENT, STORE RESULT AS UNMATCHED.
.I BWAGENCY="i",$$HRCN1^BWUTL1(BWDFN,DUZ(2))'=+BWHRCN D Q
..D NOMATCH^BWUPTRAN(BWYY,3)
.;
.;---> FOR NON-IHS AGENCY, IF SSN# FOR THIS RESULT DOES NOT
.;---> MATCH SSN# FOR THIS PATIENT, STORE RESULT AS UNMATCHED.
.I BWAGENCY'="i",$$SSN^BWUTL1(BWDFN)'=+BWSSN D Q
..D NOMATCH^BWUPTRAN(BWYY,6)
.;
.;---> TEXT ALREADY STORED FOR THIS IEN IN PROCEDURE FILE (^BWPCD).
.I $O(^BWPCD(BWY,1,0)) D NOMATCH^BWUPTRAN(BWYY,2) Q
.;
.;---> TRANSFER THIS LAB RESULT INTO IT'S PROCEDURE.
.D TRANSFER^BWUPTRAN(BWYY,BWY)
.;
W !?5,"Number of results successfully matched: ",BWMATCH
W !?5,"Number of results NOT matched.........: ",BWNOMAT,!
Q
BWUPRNI ;IHS/ANMC/MWR - UPLOAD: RESULTS FROM CORNING;15-Feb-2003 22:13;PLS
+1 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CONVERTS NICHOL'S LAB RESULTS FROM FIXED TO VARIABLE, THEN FORMATS
+4 ;; REPORTS AND PLACES THEM IN BW PROCEDURE FILE (WP) WITH PATIENTS.
+5 ;
+6 ;---> * FOR CORNING LAB *
+7 ;
+8 ;---> CONVERSION AND TRANSFER OF RESULTS FOR * CORNING LAB *.
+9 ;---> THIS ROUTINE IS CALLED BY ^BWUPLD. "CVT" CONVERTS CORNING LAB
+10 ;---> FIXED LENGTH ASCII TEXT LAB RESULTS ABBREVIATIONS INTO VARIABLE
+11 ;---> RECORDS AND ADDS THEM TO THE "BW UPLD RESULTS TEMP (CORNING)"
+12 ;---> FILE.
+13 ;--->
+14 ;---> "TRANS" FORMATS AND TRANSFERS ENTRIES FROM THE "BW UPLD RESULTS
+15 ;---> TEMP (CORNING)" FILE INTO THE WP FIELD OF THE "BW PROCEDURE"
+16 ;---> FILE. MATCHING IS DONE ON THE BASIS OF THE ACCESSION#, THE "B"
+17 ;---> CROSSREFERENCE AND THEN CHART# FOR IHS, SSN# FOR NON-IHS.
+18 ;
CVT(LINE,PIECE) ;EP
+1 ;---> COVERT FIXED LENGTH INTO "^" DELIMITED VARIABLE LENGTH.
+2 ;---> PIECE=1 SAYS PIECE BWLINE WHEN RETURNED TO BWUPLD.
+3 NEW Y,Z
+4 ;---> TRANSLATE ALL "^" INTO "`".
+5 SET Y=$TRANSLATE(LINE,"^","`")
+6 ;---> EXTRACT THE ACCESSION#, TRIM OFF ANY TRAILING SPACES.
+7 SET Z=$$TRIM($EXTRACT(Y,106,117))
+8 ;---> IF ACCESSION#="", SET ACC#=NICHOL'S REQUISITION#.
+9 IF Z']""
SET Z=$$TRIM($EXTRACT(Y,47,62))
+10 ;---> EXTRACT THE PATIENT NAME, TRIM TRAILING SPACES.
+11 SET Z=Z_U_$$TRIM($EXTRACT(Y,9,32))
+12 ;---> EXTRACT THE PATIENT SSN/ACCT#, TRIM TRAILING SPACES.
+13 SET Z=Z_U_$$TRIM($EXTRACT(Y,33,46))
+14 ;---> EXTRACT THE REQUISITION#, TRIM TRAILING SPACES.
+15 SET Z=Z_U_$$TRIM($EXTRACT(Y,47,62))
+16 ;---> EXTRACT THE DATE OF BIRTH.
+17 SET Z=Z_U_$$TRIM($EXTRACT(Y,63,72))
+18 ;---> EXTRACT THE AGE.
+19 SET Z=Z_U_$$TRIM($EXTRACT(Y,73,76))
+20 ;---> EXTRACT THE HOSPITAL ID#/CHART#, TRIM TRAILING SPACES.
+21 SET Z=Z_U_$$TRIM($EXTRACT(Y,77,88))
+22 ;---> EXTRACT THE REFERRING PHYSICIAN, TRIM TRAILING SPACES.
+23 SET Z=Z_U_$$TRIM($EXTRACT(Y,89,105))
+24 ;---> EXTRACT THE ACCOUNT#, TRIM TRAILING AND LEADING SPACES.
+25 SET Z=Z_U_$$TRIM2($$TRIM($EXTRACT(Y,1,8)))
+26 ;---> EXTRACT THE TEST NAME, TRIM TRAILING SPACES.
+27 SET Z=Z_U_$$TRIM($EXTRACT(Y,118,139))
+28 ;---> EXTRACT THE COLLECTION DATE.
+29 SET Z=Z_U_$$TRIM($EXTRACT(Y,140,147))
+30 ;---> EXTRACT THE LOCATION.
+31 SET Z=Z_U_$$TRIM($EXTRACT(Y,148,153))
+32 ;---> EXTRACT THE SPECIMEN SOURCE, TRIM TRAILING SPACES.
+33 SET Z=Z_U_$$TRIM($EXTRACT(Y,154,178))
+34 ;---> EXTRACT THE SPECIMEN ADEQUACY, TRIM TRAILING SPACES.
+35 SET Z=Z_U_$$TRIM($EXTRACT(Y,179,203))
+36 ;---> EXTRACT THE GENERAL CATEGORIZATION, TRIM TRAILING SPACES.
+37 SET Z=Z_U_$$TRIM($EXTRACT(Y,204,228))
+38 ;---> EXTRACT THE DESCRIPTIVE DIAGNOSIS, TRIM TRAILING SPACES.
+39 SET Z=Z_U_$$TRIM($EXTRACT(Y,229,253))
+40 ;---> EXTRACT THE SQUAMOUS CELLS, TRIM TRAILING SPACES.
+41 SET Z=Z_U_$$TRIM($EXTRACT(Y,254,278))
+42 ;---> EXTRACT THE GLANDULAR CELLS, TRIM TRAILING SPACES.
+43 SET Z=Z_U_$$TRIM($EXTRACT(Y,279,303))
+44 ;---> EXTRACT THE REACTIVE/REPAIRATIVE, TRIM TRAILING SPACES.
+45 SET Z=Z_U_$$TRIM($EXTRACT(Y,304,328))
+46 ;---> EXTRACT THE INFECTION, TRIM TRAILING SPACES.
+47 SET Z=Z_U_$$TRIM($EXTRACT(Y,329,353))
+48 ;---> EXTRACT THE INFECTION NOTATION, TRIM TRAILING SPACES.
+49 SET Z=Z_U_$$TRIM($EXTRACT(Y,354,378))
+50 ;---> EXTRACT THE HORMONAL EVALUATION, TRIM TRAILING SPACES.
+51 SET Z=Z_U_$$TRIM($EXTRACT(Y,379,403))
+52 ;---> EXTRACT THE HORMONAL EVALUATION NOTATION, TRIM TRAILING SPACES.
+53 SET Z=Z_U_$$TRIM($EXTRACT(Y,404,428))
+54 ;---> EXTRACT THE COMMENT, TRIM TRAILING SPACES.
+55 SET Z=Z_U_$$TRIM($EXTRACT(Y,429,453))
+56 ;---> EXTRACT THE REVIEWER, TRIM TRAILING SPACES.
+57 SET LINE=Z_U_$$TRIM($EXTRACT(Y,454,478))
SET PIECE=1
+58 QUIT
+59 ;
TRIM(X) ;EP
+1 ;---> TRIM OFF ANY TRAILING SPACES.
+2 IF '$DATA(X)
QUIT ""
+3 NEW L
SET L=$LENGTH(X)
+4 FOR
IF $EXTRACT(X,L)'=" "
QUIT
SET L=L-1
+5 QUIT $EXTRACT(X,1,L)
+6 ;
TRIM2(X) ;EP
+1 ;---> TRIM OFF ANY LEADING SPACES.
+2 IF '$DATA(X)
QUIT ""
+3 NEW I,L
SET L=$LENGTH(X)
+4 FOR I=1:1
IF $EXTRACT(X,I)'=" "
QUIT
+5 QUIT $EXTRACT(X,I,L)
+6 ;
+7 ;
TRANS ;EP
+1 ;---> * FOR CORNING LAB *
+2 ;---> "TRANS" FORMATS AND TRANSFERS ENTRIES FROM THE "BW UPLD RESULTS
+3 ;---> TEMP (CORNING)" FILE INTO THE WP FIELD OF THE "BW PROCEDURE"
+4 ;---> FILE. MATCHING IS DONE ON THE BASIS OF THE ACCESSION#, THE "B"
+5 ;---> CROSSREFERENCE.
+6 ;---> BWY WILL EQUAL THE IEN OF THE PROCEDURE, FILE 9002086.1.
+7 ;---> BWYY WILL EQUAL THE IEN OF THE LAB RESULT, FILE 9002086.82.
+8 NEW BWAGENCY,BWDFN,BWHRCN,BWSSN,BWY,BWYY
+9 SET (BWMATCH,BWNOMAT)=0
SET BWTAB=" "
+10 WRITE !?5,"Transferring to ""BW PROCEDURE"" FILE..."
HANG 1
+11 SET BWYY=0
+12 FOR
SET BWYY=$ORDER(^BWRNI(BWYY))
IF 'BWYY
QUIT
Begin DoDot:1
+13 ;---> GET ACCESSION#, CHART#, AND SSN# FROM LAB RESULT.
+14 SET BWACC=$PIECE(^BWRNI(BWYY,0),U)
SET BWHRCN=$PIECE(^(0),U,7)
SET BWSSN=$PIECE(^(0),U,3)
+15 ;
+16 ;---> GET IEN OF THE PROCEDURE, FILE 9002086.1, FOR THIS ACCESSION#.
+17 SET BWY=$ORDER(^BWPCD("B",BWACC,0))
+18 ;
+19 ;---> XREF FAILED TO PRODUCE IEN IN PROCEDURE FILE (^BWPCD).
+20 IF BWY=""
DO NOMATCH^BWUPTRAN(BWYY,1)
QUIT
+21 IF '$DATA(^BWPCD(BWY,0))
DO NOMATCH^BWUPTRAN(BWYY,1)
QUIT
+22 ;
+23 ;---> GET DFN AND AGENCY (IHS, STATE, OR VA).
+24 SET BWDFN=$PIECE(^BWPCD(BWY,0),U,2)
+25 SET BWAGENCY=$$AGENCY^BWUTL5(DUZ(2))
+26 ;
+27 ;---> IF AGENCY IS IHS AND THE CHART# FOR THIS RESULT DOES NOT
+28 ;---> MATCH CHART# FOR THIS PATIENT, STORE RESULT AS UNMATCHED.
+29 IF BWAGENCY="i"
IF $$HRCN1^BWUTL1(BWDFN,DUZ(2))'=+BWHRCN
Begin DoDot:2
+30 DO NOMATCH^BWUPTRAN(BWYY,3)
End DoDot:2
QUIT
+31 ;
+32 ;---> FOR NON-IHS AGENCY, IF SSN# FOR THIS RESULT DOES NOT
+33 ;---> MATCH SSN# FOR THIS PATIENT, STORE RESULT AS UNMATCHED.
+34 IF BWAGENCY'="i"
IF $$SSN^BWUTL1(BWDFN)'=+BWSSN
Begin DoDot:2
+35 DO NOMATCH^BWUPTRAN(BWYY,6)
End DoDot:2
QUIT
+36 ;
+37 ;---> TEXT ALREADY STORED FOR THIS IEN IN PROCEDURE FILE (^BWPCD).
+38 IF $ORDER(^BWPCD(BWY,1,0))
DO NOMATCH^BWUPTRAN(BWYY,2)
QUIT
+39 ;
+40 ;---> TRANSFER THIS LAB RESULT INTO IT'S PROCEDURE.
+41 DO TRANSFER^BWUPTRAN(BWYY,BWY)
+42 ;
End DoDot:1
+43 WRITE !?5,"Number of results successfully matched: ",BWMATCH
+44 WRITE !?5,"Number of results NOT matched.........: ",BWNOMAT,!
+45 QUIT
