- 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 Feb 18, 2025@23:07:06 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