Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7VLCM7

LA7VLCM7.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ;
  1. DOD6247 ;
  1. ; Prompts user for Message Configuration in #62.47 to add
  1. ; the DOD local codes to.
  1. N DIC,X,Y
  1. S DIC(0)="ABEOQV"
  1. S DIC=62.48
  1. S DIC("A")="Select MESSAGE CONFIGURATION: "
  1. S DIC("S")="I $P(^(0),U,9)=10 I $P(^(0),U,1)["" HOST """
  1. D ^DIC
  1. K DIC
  1. I Y'>0 Q
  1. D ADDDOD(+Y)
  1. Q
  1. ;
  1. ADDDOD(R6248) ;
  1. ; Add DoD's local codes from DATA1 into file #62.47
  1. ; Private method for DOD6247 above
  1. ; Inputs
  1. ; R6248 : File #62.48 IEN
  1. ;
  1. N SEP,I,DATA,R6247,CODE,SYS,PURP,MSGCFG,IEN,LAFDA,LAMSG,DIERR
  1. N R1,R2,FOUND,CNT,CONCPT,OVERIDE,NODE
  1. S R6248=$G(R6248)
  1. Q:'R6248
  1. Q:'$D(^LAHM(62.48,R6248))
  1. S MSGCFG=$G(^LAHM(62.48,R6248,0))
  1. S MSGCFG=$P(MSGCFG,"^",1)
  1. Q:MSGCFG=""
  1. S SEP="|"
  1. S CNT=0
  1. ; If data is added I's FOR loop needs adjusted
  1. F I=3:1:10 S DATA=$T(DATA1+I) Q:DATA="" D ;
  1. . S DATA=$$TRIM^XLFSTR(DATA)
  1. . S DATA=$$TRIM^XLFSTR(DATA,"L",";")
  1. . Q:DATA=""
  1. . S CONCPT=$P(DATA,SEP,4)
  1. . S R6247=$O(^LAB(62.47,"B",CONCPT,0))
  1. . I 'R6247 D Q ;
  1. . . W !,"Missing Concept: ",CONCPT
  1. . S CODE=$P(DATA,SEP,1)
  1. . S SYS=$P(DATA,SEP,2)
  1. . S PURP=$P(DATA,SEP,3)
  1. . S OVERIDE=$P(DATA,SEP,5)
  1. . ; only add if not already on file for msg cfg
  1. . S NODE="^LAB(62.47,""AF"","""_SYS_""","""_CODE_""")"
  1. . S FOUND=0
  1. . 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 ;
  1. . . S R1=$QS(NODE,5)
  1. . . S R2=$QS(NODE,6)
  1. . . S DATA=$G(^LAB(62.47,R1,1,R2,2))
  1. . . I $P(DATA,"^",2)=R6248 S FOUND=1
  1. . ;
  1. . I FOUND D Q ;
  1. . . W !,"Skipping ",CODE," ",SYS," (already in file)"
  1. . ;
  1. . S CNT=CNT+1
  1. . W !,"Adding ",CODE," ",SYS
  1. . K IEN,LAFDA,LAMSG,DIERR
  1. . S IEN="+1,"_R6247_","
  1. . S LAFDA(1,62.4701,IEN,.01)=CODE
  1. . S LAFDA(1,62.4701,IEN,.02)=SYS
  1. . S LAFDA(1,62.4701,IEN,.03)=PURP
  1. . S LAFDA(1,62.4701,IEN,.05)="N"
  1. . S LAFDA(1,62.4701,IEN,2.2)=MSGCFG
  1. . S LAFDA(1,62.4701,IEN,.04)=OVERIDE
  1. . D UPDATE^DIE("E","LAFDA(1)","","LAMSG")
  1. . I '$D(DIERR) W " (okay)"
  1. . I $D(DIERR) D ;
  1. . . W " (error)"
  1. . . D MSG^DIALOG("WE","","","","LAMSG") W !
  1. . ;
  1. Q
  1. ;
  1. DATA1 ;
  1. ; Used with ADDDOD above
  1. ;;CODE|SYSTEM|PURPOSE|CONCEPT|OVERRIDE
  1. ;;0410.2|99LAB|RESULT|BACTERIOLOGY REPORT
  1. ;;0410.3|99LAB|RESULT|GRAM STAIN
  1. ;;0420.1|99LAB|RESULT|ACID FAST STAIN QUANTITY|MYCOBACTERIA REPORT
  1. ;;0420.2|99LAB|RESULT|MYCOBACTERIA REPORT
  1. ;;0430.2|99LAB|RESULT|FUNGAL REPORT REMARK
  1. ;;0430.3|99LAB|RESULT|MYCOLOGY SMEAR/PREP
  1. ;;0440.3|99LAB|RESULT|PARASITE REPORT REMARK
  1. ;;0450.1|99LAB|RESULT|VIROLOGY REPORT
  1. Q
  1. ;
  1. MAPABS ;
  1. ; Main entry point for Mapping ABS codes. Allows for queuing.
  1. N DIR,X,Y,RTN,NOASK,QUE,POP,DTOUT,DUOUT,DIRUT,DIROUT
  1. S NOASK=0
  1. S DIR(0)="YAO"
  1. S DIR("A")="Report only? "
  1. S DIR("B")="YES"
  1. S DIR("?")="YES only displays the report, NO allows the user to accept the suggested mapping."
  1. D ^DIR
  1. I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
  1. S NOASK=+Y
  1. S RTN="MAPABSQ^LA7VLCM7("_NOASK_")"
  1. ;only allow queuing of "NO ASK" (report only) requests
  1. I NOASK D Q:QUE<0 ;
  1. . S QUE=$$QUE^LA7VLCM1(RTN,"Map Antibiotic Susceptibilities")
  1. . Q:QUE<0
  1. . I 'QUE D ;
  1. . . D MAPABSQ(1)
  1. . . D ^%ZISC
  1. . ;
  1. I 'NOASK D MAPABSQ(0)
  1. Q
  1. ;
  1. MAPABSQ(NOASK) ;
  1. ; Map Antibiotic Susceptibilities
  1. ; Private method for MAPABS above
  1. ; Goes through #62.06 and checks if LOINC code is in #62.47
  1. ; and has a RELATED ENTRY entered.
  1. ; #62.06 field #64 -> #64 field #25 -> #62.47
  1. ;
  1. N R6206,R64,R953,R6247,R62471,LOINC,LSFN,DATA
  1. N CNT,CNT1,CNT2,CNT3,CNT4,CNT5,CNT6,X,Y,LAIEN,LAFDA,LAMSG,DIERR
  1. N ABNAME,ABINAME,NODE,FOUND,LFSN,ISSUSC,LALOCK
  1. N STOP,DIR,DIROUT,DIOUT,DTOUT,DIRUT
  1. S NOASK=+$G(NOASK)
  1. I $D(ZTQUEUED) S NOASK=1
  1. S R6206=0
  1. S (CNT,CNT1,CNT2,CNT3,CNT4,CNT5,CNT6)=0
  1. I '$D(ZTQUEUED) I $E($G(IOST),1,2)="C-" D WAIT^DICD W !
  1. S STOP=0
  1. ;
  1. F S R6206=$O(^LAB(62.06,R6206)) Q:'R6206 D Q:STOP ;
  1. . S CNT6=CNT6+1 ;# of #62.06 entries
  1. ;
  1. S R6206=0
  1. F S R6206=$O(^LAB(62.06,R6206)) Q:'R6206 D Q:STOP ;
  1. . S CNT=CNT+1
  1. . S DATA=$G(^LAB(62.06,R6206,0))
  1. . S ABNAME=$P(DATA,"^",1)
  1. . S ABINAME=$P(DATA,"^",4)
  1. . S Y=ABINAME S Y(0)=Y S ABINAME=$$GET1^DID(63.3,Y,"","LABEL")
  1. . I ABINAME="" D ;
  1. . . S ABINAME=$P(DATA,"^",8)
  1. . . S Y=ABINAME S Y(0)=Y S ABINAME=$$GET1^DID(63.39,Y,"","LABEL")
  1. . S DATA=$G(^LAB(62.06,R6206,64))
  1. . S R64=$P(DATA,"^",1)
  1. . I 'R64 D Q ;
  1. . . W $C(7),!!,"---No NLT code in #62.06 for ",ABNAME," (",R6206,")"
  1. . . D:NOASK PF(1)
  1. . ;
  1. . S DATA=$G(^LAM(R64,9))
  1. . S R953=$P(DATA,"^",1)
  1. . I 'R953 D Q ;
  1. . . S X=$G(^LAM(R64,0))
  1. . . S X=$P(X,"^",1)
  1. . . W $C(7),!!,"---No DEFAULT LOINC CODE in #64:",R64," for ",X," (#62.06:",R6206,")"
  1. . . D:NOASK PF(1)
  1. . ;
  1. . S LOINC=$$GET1^DIQ(95.3,R953_",",.01,"","","MSG")
  1. . S LFSN=$G(^LAB(95.3,R953,80))
  1. . Q:LOINC=""
  1. . S DATA=$G(^LAB(95.3,R953,0))
  1. . S ISSUSC=$P(DATA,"^",6)
  1. . I ISSUSC'=576 D ;
  1. . . W $C(7),!,"---LOINC ",LOINC," in #64:",R64," not a susceptibility (#62.06:",R6206,")"
  1. . . D:NOASK PF(1)
  1. . . W !,"-----",LFSN
  1. . . D:NOASK PF(1)
  1. . ;
  1. . S NODE="^LAB(62.47,""AF"",""LN"","""_LOINC_""")"
  1. . S FOUND=0
  1. . 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 ;
  1. . . S R6247=$QS(NODE,5)
  1. . . S R62471=$QS(NODE,6)
  1. . . I "^7^21^"'[("^"_R6247_"^") Q
  1. . . S DATA=$G(^LAB(62.47,R6247,1,R62471,0))
  1. . . S X=$P(DATA,"^",5)
  1. . . S CNT1=CNT1+1
  1. . . Q:'X ;not national
  1. . . S CNT2=CNT2+1
  1. . . S FOUND=1
  1. . . S DATA=$G(^LAB(62.47,R6247,1,R62471,2))
  1. . . S X=$P(DATA,"^",1) ;RELATED ENTRY
  1. . . I X="" D Q ;
  1. . . . S CNT3=CNT3+1
  1. . . . W !!,"#62.06:",R6206," #95.3:",R953," #62.47:",R6247,",",R62471
  1. . . . D:NOASK PF(1)
  1. . . . W !,"No RELATED ENTRY for LOINC ",LOINC D:NOASK PF(1)
  1. . . . W !," ",LFSN D:NOASK PF(1)
  1. . . . S X="Use "_ABNAME
  1. . . . I ABINAME'=ABNAME S X=X_" ("_ABINAME_")"
  1. . . . S X=X_" for this mapping? "
  1. . . . I NOASK W !,X D PF(1) Q
  1. . . . K DIR
  1. . . . S DIR(0)="YAO^"
  1. . . . S DIR("A")=X
  1. . . . S DIR("B")="NO"
  1. . . . D ^DIR
  1. . . . I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S STOP=1 Q
  1. . . . I Y D ;
  1. . . . . S LALOCK=$NA(^LAB(62.47,R6247,1,R62471))
  1. . . . . S X=$$GETLOCK^LRUTIL(LALOCK)
  1. . . . . I 'X D Q ;
  1. . . . . . W !!,$C(7)," ** Could not lock the entry. **",! H 3
  1. . . . . ;
  1. . . . . K LAIEN,LAFDA,LAMSG,DIERR
  1. . . . . S LAIEN=R62471_","_R6247_","
  1. . . . . S X=R6206_";LAB(62.06,"
  1. . . . . S LAFDA(1,62.4701,LAIEN,2.1)=X
  1. . . . . D FILE^DIE("","LAFDA(1)","LAMSG")
  1. . . . . S CNT5=CNT5+1
  1. . . . . L -@LALOCK
  1. . . . W !
  1. . . ;
  1. . ;
  1. . I 'FOUND D Q ;
  1. . . S CNT4=CNT4+1
  1. . ;
  1. W !!," #62.06 records searched: ",CNT," of ",CNT6
  1. W !," Total #62.47 records searched: ",CNT1
  1. W !," Total NATL codes: ",CNT2
  1. W !," Total #62.47 codes without mapping: ",$S(CNT1>0:CNT3,1:"n/a")
  1. W !," Total #62.06 LOINC codes not in #62.47: ",CNT4
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. Q
  1. ;
  1. PF(NOTTERM,PGCNT) ;
  1. ; Page Feed
  1. ; Inputs
  1. ; NOTTERM <opt> : NOT TERMinal (dflt=1)
  1. ; : 1=do nothing if a console device
  1. ; PGCNT <byref><opt>:
  1. N NEWPG
  1. S NEWPG=0
  1. S NOTTERM=$G(NOTTERM,1)
  1. I NOTTERM I $E($G(IOST),1,2)="C-" Q:$Q 0 Q ;
  1. I $G(IOSL) I $Y+1>(IOSL-1) D ;
  1. . I $G(IOF)'="" W @IOF
  1. . S $Y=0
  1. . S NEWPG=1
  1. . S PGCNT=$G(PGCNT)+1
  1. Q:$Q NEWPG
  1. Q