LA7VLCM7 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;03/07/12 15:59
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
DOD6247 ;
; Prompts user for Message Configuration in #62.47 to add
; the DOD local codes to.
N DIC,X,Y
S DIC(0)="ABEOQV"
S DIC=62.48
S DIC("A")="Select MESSAGE CONFIGURATION: "
S DIC("S")="I $P(^(0),U,9)=10 I $P(^(0),U,1)["" HOST """
D ^DIC
K DIC
I Y'>0 Q
D ADDDOD(+Y)
Q
;
ADDDOD(R6248) ;
; Add DoD's local codes from DATA1 into file #62.47
; Private method for DOD6247 above
; Inputs
; R6248 : File #62.48 IEN
;
N SEP,I,DATA,R6247,CODE,SYS,PURP,MSGCFG,IEN,LAFDA,LAMSG,DIERR
N R1,R2,FOUND,CNT,CONCPT,OVERIDE,NODE
S R6248=$G(R6248)
Q:'R6248
Q:'$D(^LAHM(62.48,R6248))
S MSGCFG=$G(^LAHM(62.48,R6248,0))
S MSGCFG=$P(MSGCFG,"^",1)
Q:MSGCFG=""
S SEP="|"
S CNT=0
; If data is added I's FOR loop needs adjusted
F I=3:1:10 S DATA=$T(DATA1+I) Q:DATA="" D ;
. S DATA=$$TRIM^XLFSTR(DATA)
. S DATA=$$TRIM^XLFSTR(DATA,"L",";")
. Q:DATA=""
. S CONCPT=$P(DATA,SEP,4)
. S R6247=$O(^LAB(62.47,"B",CONCPT,0))
. I 'R6247 D Q ;
. . W !,"Missing Concept: ",CONCPT
. S CODE=$P(DATA,SEP,1)
. S SYS=$P(DATA,SEP,2)
. S PURP=$P(DATA,SEP,3)
. S OVERIDE=$P(DATA,SEP,5)
. ; only add if not already on file for msg cfg
. S NODE="^LAB(62.47,""AF"","""_SYS_""","""_CODE_""")"
. S FOUND=0
. F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'="AF" Q:$QS(NODE,3)'=SYS Q:$QS(NODE,4)'=CODE D Q:FOUND ;
. . S R1=$QS(NODE,5)
. . S R2=$QS(NODE,6)
. . S DATA=$G(^LAB(62.47,R1,1,R2,2))
. . I $P(DATA,"^",2)=R6248 S FOUND=1
. ;
. I FOUND D Q ;
. . W !,"Skipping ",CODE," ",SYS," (already in file)"
. ;
. S CNT=CNT+1
. W !,"Adding ",CODE," ",SYS
. K IEN,LAFDA,LAMSG,DIERR
. S IEN="+1,"_R6247_","
. S LAFDA(1,62.4701,IEN,.01)=CODE
. S LAFDA(1,62.4701,IEN,.02)=SYS
. S LAFDA(1,62.4701,IEN,.03)=PURP
. S LAFDA(1,62.4701,IEN,.05)="N"
. S LAFDA(1,62.4701,IEN,2.2)=MSGCFG
. S LAFDA(1,62.4701,IEN,.04)=OVERIDE
. D UPDATE^DIE("E","LAFDA(1)","","LAMSG")
. I '$D(DIERR) W " (okay)"
. I $D(DIERR) D ;
. . W " (error)"
. . D MSG^DIALOG("WE","","","","LAMSG") W !
. ;
Q
;
DATA1 ;
; Used with ADDDOD above
;;CODE|SYSTEM|PURPOSE|CONCEPT|OVERRIDE
;;0410.2|99LAB|RESULT|BACTERIOLOGY REPORT
;;0410.3|99LAB|RESULT|GRAM STAIN
;;0420.1|99LAB|RESULT|ACID FAST STAIN QUANTITY|MYCOBACTERIA REPORT
;;0420.2|99LAB|RESULT|MYCOBACTERIA REPORT
;;0430.2|99LAB|RESULT|FUNGAL REPORT REMARK
;;0430.3|99LAB|RESULT|MYCOLOGY SMEAR/PREP
;;0440.3|99LAB|RESULT|PARASITE REPORT REMARK
;;0450.1|99LAB|RESULT|VIROLOGY REPORT
Q
;
MAPABS ;
; Main entry point for Mapping ABS codes. Allows for queuing.
N DIR,X,Y,RTN,NOASK,QUE,POP,DTOUT,DUOUT,DIRUT,DIROUT
S NOASK=0
S DIR(0)="YAO"
S DIR("A")="Report only? "
S DIR("B")="YES"
S DIR("?")="YES only displays the report, NO allows the user to accept the suggested mapping."
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
S NOASK=+Y
S RTN="MAPABSQ^LA7VLCM7("_NOASK_")"
;only allow queuing of "NO ASK" (report only) requests
I NOASK D Q:QUE<0 ;
. S QUE=$$QUE^LA7VLCM1(RTN,"Map Antibiotic Susceptibilities")
. Q:QUE<0
. I 'QUE D ;
. . D MAPABSQ(1)
. . D ^%ZISC
. ;
I 'NOASK D MAPABSQ(0)
Q
;
MAPABSQ(NOASK) ;
; Map Antibiotic Susceptibilities
; Private method for MAPABS above
; Goes through #62.06 and checks if LOINC code is in #62.47
; and has a RELATED ENTRY entered.
; #62.06 field #64 -> #64 field #25 -> #62.47
;
N R6206,R64,R953,R6247,R62471,LOINC,LSFN,DATA
N CNT,CNT1,CNT2,CNT3,CNT4,CNT5,CNT6,X,Y,LAIEN,LAFDA,LAMSG,DIERR
N ABNAME,ABINAME,NODE,FOUND,LFSN,ISSUSC,LALOCK
N STOP,DIR,DIROUT,DIOUT,DTOUT,DIRUT
S NOASK=+$G(NOASK)
I $D(ZTQUEUED) S NOASK=1
S R6206=0
S (CNT,CNT1,CNT2,CNT3,CNT4,CNT5,CNT6)=0
I '$D(ZTQUEUED) I $E($G(IOST),1,2)="C-" D WAIT^DICD W !
S STOP=0
;
F S R6206=$O(^LAB(62.06,R6206)) Q:'R6206 D Q:STOP ;
. S CNT6=CNT6+1 ;# of #62.06 entries
;
S R6206=0
F S R6206=$O(^LAB(62.06,R6206)) Q:'R6206 D Q:STOP ;
. S CNT=CNT+1
. S DATA=$G(^LAB(62.06,R6206,0))
. S ABNAME=$P(DATA,"^",1)
. S ABINAME=$P(DATA,"^",4)
. S Y=ABINAME S Y(0)=Y S ABINAME=$$GET1^DID(63.3,Y,"","LABEL")
. I ABINAME="" D ;
. . S ABINAME=$P(DATA,"^",8)
. . S Y=ABINAME S Y(0)=Y S ABINAME=$$GET1^DID(63.39,Y,"","LABEL")
. S DATA=$G(^LAB(62.06,R6206,64))
. S R64=$P(DATA,"^",1)
. I 'R64 D Q ;
. . W $C(7),!!,"---No NLT code in #62.06 for ",ABNAME," (",R6206,")"
. . D:NOASK PF(1)
. ;
. S DATA=$G(^LAM(R64,9))
. S R953=$P(DATA,"^",1)
. I 'R953 D Q ;
. . S X=$G(^LAM(R64,0))
. . S X=$P(X,"^",1)
. . W $C(7),!!,"---No DEFAULT LOINC CODE in #64:",R64," for ",X," (#62.06:",R6206,")"
. . D:NOASK PF(1)
. ;
. S LOINC=$$GET1^DIQ(95.3,R953_",",.01,"","","MSG")
. S LFSN=$G(^LAB(95.3,R953,80))
. Q:LOINC=""
. S DATA=$G(^LAB(95.3,R953,0))
. S ISSUSC=$P(DATA,"^",6)
. I ISSUSC'=576 D ;
. . W $C(7),!,"---LOINC ",LOINC," in #64:",R64," not a susceptibility (#62.06:",R6206,")"
. . D:NOASK PF(1)
. . W !,"-----",LFSN
. . D:NOASK PF(1)
. ;
. S NODE="^LAB(62.47,""AF"",""LN"","""_LOINC_""")"
. S FOUND=0
. F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'="AF" Q:$QS(NODE,3)'="LN" Q:$QS(NODE,4)'=LOINC D Q:STOP ;
. . S R6247=$QS(NODE,5)
. . S R62471=$QS(NODE,6)
. . I "^7^21^"'[("^"_R6247_"^") Q
. . S DATA=$G(^LAB(62.47,R6247,1,R62471,0))
. . S X=$P(DATA,"^",5)
. . S CNT1=CNT1+1
. . Q:'X ;not national
. . S CNT2=CNT2+1
. . S FOUND=1
. . S DATA=$G(^LAB(62.47,R6247,1,R62471,2))
. . S X=$P(DATA,"^",1) ;RELATED ENTRY
. . I X="" D Q ;
. . . S CNT3=CNT3+1
. . . W !!,"#62.06:",R6206," #95.3:",R953," #62.47:",R6247,",",R62471
. . . D:NOASK PF(1)
. . . W !,"No RELATED ENTRY for LOINC ",LOINC D:NOASK PF(1)
. . . W !," ",LFSN D:NOASK PF(1)
. . . S X="Use "_ABNAME
. . . I ABINAME'=ABNAME S X=X_" ("_ABINAME_")"
. . . S X=X_" for this mapping? "
. . . I NOASK W !,X D PF(1) Q
. . . K DIR
. . . S DIR(0)="YAO^"
. . . S DIR("A")=X
. . . S DIR("B")="NO"
. . . D ^DIR
. . . I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S STOP=1 Q
. . . I Y D ;
. . . . S LALOCK=$NA(^LAB(62.47,R6247,1,R62471))
. . . . S X=$$GETLOCK^LRUTIL(LALOCK)
. . . . I 'X D Q ;
. . . . . W !!,$C(7)," ** Could not lock the entry. **",! H 3
. . . . ;
. . . . K LAIEN,LAFDA,LAMSG,DIERR
. . . . S LAIEN=R62471_","_R6247_","
. . . . S X=R6206_";LAB(62.06,"
. . . . S LAFDA(1,62.4701,LAIEN,2.1)=X
. . . . D FILE^DIE("","LAFDA(1)","LAMSG")
. . . . S CNT5=CNT5+1
. . . . L -@LALOCK
. . . W !
. . ;
. ;
. I 'FOUND D Q ;
. . S CNT4=CNT4+1
. ;
W !!," #62.06 records searched: ",CNT," of ",CNT6
W !," Total #62.47 records searched: ",CNT1
W !," Total NATL codes: ",CNT2
W !," Total #62.47 codes without mapping: ",$S(CNT1>0:CNT3,1:"n/a")
W !," Total #62.06 LOINC codes not in #62.47: ",CNT4
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
PF(NOTTERM,PGCNT) ;
; Page Feed
; Inputs
; NOTTERM <opt> : NOT TERMinal (dflt=1)
; : 1=do nothing if a console device
; PGCNT <byref><opt>:
N NEWPG
S NEWPG=0
S NOTTERM=$G(NOTTERM,1)
I NOTTERM I $E($G(IOST),1,2)="C-" Q:$Q 0 Q ;
I $G(IOSL) I $Y+1>(IOSL-1) D ;
. I $G(IOF)'="" W @IOF
. S $Y=0
. S NEWPG=1
. S PGCNT=$G(PGCNT)+1
Q:$Q NEWPG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VLCM7 7429 printed Dec 13, 2024@01:40:43 Page 2
LA7VLCM7 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;03/07/12 15:59
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
DOD6247 ;
+1 ; Prompts user for Message Configuration in #62.47 to add
+2 ; the DOD local codes to.
+3 NEW DIC,X,Y
+4 SET DIC(0)="ABEOQV"
+5 SET DIC=62.48
+6 SET DIC("A")="Select MESSAGE CONFIGURATION: "
+7 SET DIC("S")="I $P(^(0),U,9)=10 I $P(^(0),U,1)["" HOST """
+8 DO ^DIC
+9 KILL DIC
+10 IF Y'>0
QUIT
+11 DO ADDDOD(+Y)
+12 QUIT
+13 ;
ADDDOD(R6248) ;
+1 ; Add DoD's local codes from DATA1 into file #62.47
+2 ; Private method for DOD6247 above
+3 ; Inputs
+4 ; R6248 : File #62.48 IEN
+5 ;
+6 NEW SEP,I,DATA,R6247,CODE,SYS,PURP,MSGCFG,IEN,LAFDA,LAMSG,DIERR
+7 NEW R1,R2,FOUND,CNT,CONCPT,OVERIDE,NODE
+8 SET R6248=$GET(R6248)
+9 if 'R6248
QUIT
+10 if '$DATA(^LAHM(62.48,R6248))
QUIT
+11 SET MSGCFG=$GET(^LAHM(62.48,R6248,0))
+12 SET MSGCFG=$PIECE(MSGCFG,"^",1)
+13 if MSGCFG=""
QUIT
+14 SET SEP="|"
+15 SET CNT=0
+16 ; If data is added I's FOR loop needs adjusted
+17 ;
FOR I=3:1:10
SET DATA=$TEXT(DATA1+I)
if DATA=""
QUIT
Begin DoDot:1
+18 SET DATA=$$TRIM^XLFSTR(DATA)
+19 SET DATA=$$TRIM^XLFSTR(DATA,"L",";")
+20 if DATA=""
QUIT
+21 SET CONCPT=$PIECE(DATA,SEP,4)
+22 SET R6247=$ORDER(^LAB(62.47,"B",CONCPT,0))
+23 ;
IF 'R6247
Begin DoDot:2
+24 WRITE !,"Missing Concept: ",CONCPT
End DoDot:2
QUIT
+25 SET CODE=$PIECE(DATA,SEP,1)
+26 SET SYS=$PIECE(DATA,SEP,2)
+27 SET PURP=$PIECE(DATA,SEP,3)
+28 SET OVERIDE=$PIECE(DATA,SEP,5)
+29 ; only add if not already on file for msg cfg
+30 SET NODE="^LAB(62.47,""AF"","""_SYS_""","""_CODE_""")"
+31 SET FOUND=0
+32 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'="AF"
QUIT
if $QSUBSCRIPT(NODE,3)'=SYS
QUIT
if $QSUBSCRIPT(NODE,4)'=CODE
QUIT
Begin DoDot:2
+33 SET R1=$QSUBSCRIPT(NODE,5)
+34 SET R2=$QSUBSCRIPT(NODE,6)
+35 SET DATA=$GET(^LAB(62.47,R1,1,R2,2))
+36 IF $PIECE(DATA,"^",2)=R6248
SET FOUND=1
End DoDot:2
if FOUND
QUIT
+37 ;
+38 ;
IF FOUND
Begin DoDot:2
+39 WRITE !,"Skipping ",CODE," ",SYS," (already in file)"
End DoDot:2
QUIT
+40 ;
+41 SET CNT=CNT+1
+42 WRITE !,"Adding ",CODE," ",SYS
+43 KILL IEN,LAFDA,LAMSG,DIERR
+44 SET IEN="+1,"_R6247_","
+45 SET LAFDA(1,62.4701,IEN,.01)=CODE
+46 SET LAFDA(1,62.4701,IEN,.02)=SYS
+47 SET LAFDA(1,62.4701,IEN,.03)=PURP
+48 SET LAFDA(1,62.4701,IEN,.05)="N"
+49 SET LAFDA(1,62.4701,IEN,2.2)=MSGCFG
+50 SET LAFDA(1,62.4701,IEN,.04)=OVERIDE
+51 DO UPDATE^DIE("E","LAFDA(1)","","LAMSG")
+52 IF '$DATA(DIERR)
WRITE " (okay)"
+53 ;
IF $DATA(DIERR)
Begin DoDot:2
+54 WRITE " (error)"
+55 DO MSG^DIALOG("WE","","","","LAMSG")
WRITE !
End DoDot:2
+56 ;
End DoDot:1
+57 QUIT
+58 ;
DATA1 ;
+1 ; Used with ADDDOD above
+2 ;;CODE|SYSTEM|PURPOSE|CONCEPT|OVERRIDE
+3 ;;0410.2|99LAB|RESULT|BACTERIOLOGY REPORT
+4 ;;0410.3|99LAB|RESULT|GRAM STAIN
+5 ;;0420.1|99LAB|RESULT|ACID FAST STAIN QUANTITY|MYCOBACTERIA REPORT
+6 ;;0420.2|99LAB|RESULT|MYCOBACTERIA REPORT
+7 ;;0430.2|99LAB|RESULT|FUNGAL REPORT REMARK
+8 ;;0430.3|99LAB|RESULT|MYCOLOGY SMEAR/PREP
+9 ;;0440.3|99LAB|RESULT|PARASITE REPORT REMARK
+10 ;;0450.1|99LAB|RESULT|VIROLOGY REPORT
+11 QUIT
+12 ;
MAPABS ;
+1 ; Main entry point for Mapping ABS codes. Allows for queuing.
+2 NEW DIR,X,Y,RTN,NOASK,QUE,POP,DTOUT,DUOUT,DIRUT,DIROUT
+3 SET NOASK=0
+4 SET DIR(0)="YAO"
+5 SET DIR("A")="Report only? "
+6 SET DIR("B")="YES"
+7 SET DIR("?")="YES only displays the report, NO allows the user to accept the suggested mapping."
+8 DO ^DIR
+9 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+10 SET NOASK=+Y
+11 SET RTN="MAPABSQ^LA7VLCM7("_NOASK_")"
+12 ;only allow queuing of "NO ASK" (report only) requests
+13 ;
IF NOASK
Begin DoDot:1
+14 SET QUE=$$QUE^LA7VLCM1(RTN,"Map Antibiotic Susceptibilities")
+15 if QUE<0
QUIT
+16 ;
IF 'QUE
Begin DoDot:2
+17 DO MAPABSQ(1)
+18 DO ^%ZISC
End DoDot:2
+19 ;
End DoDot:1
if QUE<0
QUIT
+20 IF 'NOASK
DO MAPABSQ(0)
+21 QUIT
+22 ;
MAPABSQ(NOASK) ;
+1 ; Map Antibiotic Susceptibilities
+2 ; Private method for MAPABS above
+3 ; Goes through #62.06 and checks if LOINC code is in #62.47
+4 ; and has a RELATED ENTRY entered.
+5 ; #62.06 field #64 -> #64 field #25 -> #62.47
+6 ;
+7 NEW R6206,R64,R953,R6247,R62471,LOINC,LSFN,DATA
+8 NEW CNT,CNT1,CNT2,CNT3,CNT4,CNT5,CNT6,X,Y,LAIEN,LAFDA,LAMSG,DIERR
+9 NEW ABNAME,ABINAME,NODE,FOUND,LFSN,ISSUSC,LALOCK
+10 NEW STOP,DIR,DIROUT,DIOUT,DTOUT,DIRUT
+11 SET NOASK=+$GET(NOASK)
+12 IF $DATA(ZTQUEUED)
SET NOASK=1
+13 SET R6206=0
+14 SET (CNT,CNT1,CNT2,CNT3,CNT4,CNT5,CNT6)=0
+15 IF '$DATA(ZTQUEUED)
IF $EXTRACT($GET(IOST),1,2)="C-"
DO WAIT^DICD
WRITE !
+16 SET STOP=0
+17 ;
+18 ;
FOR
SET R6206=$ORDER(^LAB(62.06,R6206))
if 'R6206
QUIT
Begin DoDot:1
+19 ;# of #62.06 entries
SET CNT6=CNT6+1
End DoDot:1
if STOP
QUIT
+20 ;
+21 SET R6206=0
+22 ;
FOR
SET R6206=$ORDER(^LAB(62.06,R6206))
if 'R6206
QUIT
Begin DoDot:1
+23 SET CNT=CNT+1
+24 SET DATA=$GET(^LAB(62.06,R6206,0))
+25 SET ABNAME=$PIECE(DATA,"^",1)
+26 SET ABINAME=$PIECE(DATA,"^",4)
+27 SET Y=ABINAME
SET Y(0)=Y
SET ABINAME=$$GET1^DID(63.3,Y,"","LABEL")
+28 ;
IF ABINAME=""
Begin DoDot:2
+29 SET ABINAME=$PIECE(DATA,"^",8)
+30 SET Y=ABINAME
SET Y(0)=Y
SET ABINAME=$$GET1^DID(63.39,Y,"","LABEL")
End DoDot:2
+31 SET DATA=$GET(^LAB(62.06,R6206,64))
+32 SET R64=$PIECE(DATA,"^",1)
+33 ;
IF 'R64
Begin DoDot:2
+34 WRITE $CHAR(7),!!,"---No NLT code in #62.06 for ",ABNAME," (",R6206,")"
+35 if NOASK
DO PF(1)
End DoDot:2
QUIT
+36 ;
+37 SET DATA=$GET(^LAM(R64,9))
+38 SET R953=$PIECE(DATA,"^",1)
+39 ;
IF 'R953
Begin DoDot:2
+40 SET X=$GET(^LAM(R64,0))
+41 SET X=$PIECE(X,"^",1)
+42 WRITE $CHAR(7),!!,"---No DEFAULT LOINC CODE in #64:",R64," for ",X," (#62.06:",R6206,")"
+43 if NOASK
DO PF(1)
End DoDot:2
QUIT
+44 ;
+45 SET LOINC=$$GET1^DIQ(95.3,R953_",",.01,"","","MSG")
+46 SET LFSN=$GET(^LAB(95.3,R953,80))
+47 if LOINC=""
QUIT
+48 SET DATA=$GET(^LAB(95.3,R953,0))
+49 SET ISSUSC=$PIECE(DATA,"^",6)
+50 ;
IF ISSUSC'=576
Begin DoDot:2
+51 WRITE $CHAR(7),!,"---LOINC ",LOINC," in #64:",R64," not a susceptibility (#62.06:",R6206,")"
+52 if NOASK
DO PF(1)
+53 WRITE !,"-----",LFSN
+54 if NOASK
DO PF(1)
End DoDot:2
+55 ;
+56 SET NODE="^LAB(62.47,""AF"",""LN"","""_LOINC_""")"
+57 SET FOUND=0
+58 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'="AF"
QUIT
if $QSUBSCRIPT(NODE,3)'="LN"
QUIT
if $QSUBSCRIPT(NODE,4)'=LOINC
QUIT
Begin DoDot:2
+59 SET R6247=$QSUBSCRIPT(NODE,5)
+60 SET R62471=$QSUBSCRIPT(NODE,6)
+61 IF "^7^21^"'[("^"_R6247_"^")
QUIT
+62 SET DATA=$GET(^LAB(62.47,R6247,1,R62471,0))
+63 SET X=$PIECE(DATA,"^",5)
+64 SET CNT1=CNT1+1
+65 ;not national
if 'X
QUIT
+66 SET CNT2=CNT2+1
+67 SET FOUND=1
+68 SET DATA=$GET(^LAB(62.47,R6247,1,R62471,2))
+69 ;RELATED ENTRY
SET X=$PIECE(DATA,"^",1)
+70 ;
IF X=""
Begin DoDot:3
+71 SET CNT3=CNT3+1
+72 WRITE !!,"#62.06:",R6206," #95.3:",R953," #62.47:",R6247,",",R62471
+73 if NOASK
DO PF(1)
+74 WRITE !,"No RELATED ENTRY for LOINC ",LOINC
if NOASK
DO PF(1)
+75 WRITE !," ",LFSN
if NOASK
DO PF(1)
+76 SET X="Use "_ABNAME
+77 IF ABINAME'=ABNAME
SET X=X_" ("_ABINAME_")"
+78 SET X=X_" for this mapping? "
+79 IF NOASK
WRITE !,X
DO PF(1)
QUIT
+80 KILL DIR
+81 SET DIR(0)="YAO^"
+82 SET DIR("A")=X
+83 SET DIR("B")="NO"
+84 DO ^DIR
+85 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
SET STOP=1
QUIT
+86 ;
IF Y
Begin DoDot:4
+87 SET LALOCK=$NAME(^LAB(62.47,R6247,1,R62471))
+88 SET X=$$GETLOCK^LRUTIL(LALOCK)
+89 ;
IF 'X
Begin DoDot:5
+90 WRITE !!,$CHAR(7)," ** Could not lock the entry. **",!
HANG 3
End DoDot:5
QUIT
+91 ;
+92 KILL LAIEN,LAFDA,LAMSG,DIERR
+93 SET LAIEN=R62471_","_R6247_","
+94 SET X=R6206_";LAB(62.06,"
+95 SET LAFDA(1,62.4701,LAIEN,2.1)=X
+96 DO FILE^DIE("","LAFDA(1)","LAMSG")
+97 SET CNT5=CNT5+1
+98 LOCK -@LALOCK
End DoDot:4
+99 WRITE !
End DoDot:3
QUIT
+100 ;
End DoDot:2
if STOP
QUIT
+101 ;
+102 ;
IF 'FOUND
Begin DoDot:2
+103 SET CNT4=CNT4+1
End DoDot:2
QUIT
+104 ;
End DoDot:1
if STOP
QUIT
+105 WRITE !!," #62.06 records searched: ",CNT," of ",CNT6
+106 WRITE !," Total #62.47 records searched: ",CNT1
+107 WRITE !," Total NATL codes: ",CNT2
+108 WRITE !," Total #62.47 codes without mapping: ",$SELECT(CNT1>0:CNT3,1:"n/a")
+109 WRITE !," Total #62.06 LOINC codes not in #62.47: ",CNT4
+110 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+111 QUIT
+112 ;
PF(NOTTERM,PGCNT) ;
+1 ; Page Feed
+2 ; Inputs
+3 ; NOTTERM <opt> : NOT TERMinal (dflt=1)
+4 ; : 1=do nothing if a console device
+5 ; PGCNT <byref><opt>:
+6 NEW NEWPG
+7 SET NEWPG=0
+8 SET NOTTERM=$GET(NOTTERM,1)
+9 ;
IF NOTTERM
IF $EXTRACT($GET(IOST),1,2)="C-"
if $QUIT
QUIT 0
QUIT
+10 ;
IF $GET(IOSL)
IF $Y+1>(IOSL-1)
Begin DoDot:1
+11 IF $GET(IOF)'=""
WRITE @IOF
+12 SET $Y=0
+13 SET NEWPG=1
+14 SET PGCNT=$GET(PGCNT)+1
End DoDot:1
+15 if $QUIT
QUIT NEWPG
+16 QUIT
