LRVRMI3.m

LRVRMI3 ;DALOI/STAFF - LAB MICRO LEDI INTERFACE ;09/07/16  08:09

 ;;5.2;LAB SERVICE;**350,427,453,474**;Sep 27, 1994;Build 14

 ;

 ; Part of Micro LEDI interface.  It is a continuation of ^LRVRMI4 and ^LRVRMI2. Processes data in the temp global ^TMP("LRMI")

 ; and stores it into the appropriate sections of the Lab Data Microbiology file (#63.05).

 ;

 ;

NODE(LRNODE) ;  Process similar multiples - nodes 15,19-31

 ; Call with LRNODE = node in MI subscript to process

 ;

 N DIERR,IEN,LRCMT,LRFDA,LRFDAIEN,LRFILE,LRERR,LRIEN,LRMSG,LRPL,LRX,X

 ; Mycology smear/prep^^^^Preliminary bacteriology comment^Preliminary virology comment^Preliminary parasite comment^Preliminary mycology comment^Preliminary TB comment^

 ; Parasitology smear/prep^Bacteriology smear/prep^Bacteriology test^Parasite test^Mycology test^TB test^Virology test^Sterility test

 ;

 S LRFILE=$P("63.371^^^^63.06^63.431^63.1^63.11^63.18^63.341^63.291^63.061^63.361^63.111^63.181^63.432^63.292^","^",LRNODE-14)

 M LRCMT=^LR(LRDFN,"MI",LRIDT,LRNODE)

 ;

 S IEN=0

 F  S IEN=$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,LRNODE,IEN)) Q:IEN<1  D

 . S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,LRNODE,IEN,0)),LRX=$S(LRX'="":LRX,1:" ")

 . I LRX'=" ",$$DUPCHK^LRVRMI3(LRLL,LRPROF,.LRCMT,LRX) Q

 . S LRFDA(1,LRFILE,"+"_IEN_","_LRIDT_","_LRDFN_",",.01)=LRX

 . ;S LRFDAIEN(IEN)=IEN

 . ;

 . ; if result came across in NTE, PL and status info will be under ^(0) node

 . I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,LRNODE,0)) D  ;

 . . S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,LRNODE,0))

 . . S X=$P(LRX,"^",4)

 . . D STAT4CMT(LRFILE,X,.LRSTATUS)

 . . I $P(LRX,"^") S LRPL(IEN)=$P(LRX,"^")

 . ;

 . ; if result came across in OBX, PL and status info will be under ^(IEN,0,0) node

 . I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,LRNODE,IEN,0,0)) D  ;

 . . S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,LRNODE,IEN,0,0))

 . . S X=$P(LRX,"^",4)

 . . D STAT4CMT(LRFILE,X,.LRSTATUS)

 . . I $P(LRX,"^") S LRPL(IEN)=$P(LRX,"^")

 . ;

 ;

 I '$D(LRFDA) Q

 ;

 D UPDATE^DIE("","LRFDA(1)","LRFDAIEN","LRERR")

 S IEN=0

 F  S IEN=$O(LRPL(IEN)) Q:'IEN  D

 . I $G(LRFDAIEN(IEN)) D SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_","_LRNODE_","_LRFDAIEN(IEN),LRPL(IEN))

 ;

 ;

 ; Update d/t approved and user approving

 S LRX=$$RPTDT(LRDFN,LRIDT,LRNODE,LRNOW,$S($G(LRDUZ):LRDUZ,1:$G(DUZ)))

 ;

 Q

 ;

 ;

SETPL(NODE) ; Setup LRPL array

 ; Call with NODE = node in MI subscript to retrieve the performing lab

 ;

 N LRX

 S LRX=^TMP("LRMI",$J,LRDFN,"MI",LRIDT,NODE,IEN,0,0)

 I $P(LRX,"^") S LRPL(IEN)=$P(LRX,"^")

 Q

 ;

 ;

STOREPL(NODE) ; Set performing lab

 ; Call with NODE = node in MI subscript to retrieve the performing lab

 N IEN

 S IEN=0

 F  S IEN=$O(LRPL(IEN)) Q:'IEN  I $G(LRFDAIEN(IEN)) D SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_","_NODE_","_LRFDAIEN(IEN),LRPL(IEN))

 Q

 ;

 ;

DUPCHK(LRLL,LRPROF,LRCMT,LRCOM) ; Check for duplicates - comment stripped if spaces, force to upper case unless

 ; flag set to store duplicates (Field #2.2 of PROFILE multiple in file #68.2)

 ;

 ; Call with  LRLL = load/work list ien

 ;          LRPROF = profile ien in load/worklist

 ;           LRCMT = array containing current comments on file

 ;           LRCOM = new comment to check

 ;

 ; Returns LRDUP = 0 (no duplicate), 1 (duplicate)

 ;

 N LRDUP,LRI,LRX,LRY

 S LRDUP=0

 I '$P($G(^LRO(68.2,LRLL,10,+$G(LRPROF),0)),U,4) D

 . S LRI=0,LRY=$TR(LRCOM," ",""),LRY=$$UP^XLFSTR(LRY)

 . F  S LRI=$O(LRCMT(LRI)) Q:'LRI  D  Q:LRDUP

 . . S LRX=$P(LRCMT(LRI,0),U),LRX=$TR(LRX," ",""),LRX=$$UP^XLFSTR(LRX)

 . . I LRX=LRY S LRDUP=1

 Q LRDUP

 ;

 ;

STAT4CMT(FILE,STAT,LRSTATUS) ; Calculate status for comment nodes (eg BACT SMEAR)

 ; Inputs

 ;       FILE: The file # of the comment field in #63.

 ;       STAT: The status (eg F)

 ;   LRSTATUS:<byref>  Input and Output

 ; Outputs

 ;   LRSTATUS:

 N SUBF,FLD

 S (FLD,SUBF)=""

 ;

 I FILE=63.291 S SUBF=63.05,FLD=11.5 ; Bact Smear

 I FILE=63.341 S SUBF=63.05,FLD=15 ; Para Smear

 I FILE=63.371 S SUBF=63.05,FLD=19 ; Myco Smear

 I FILE=63.06 S SUBF=63.05,FLD=11.5 ; preliminary bacteria comment

 I FILE=63.431 S SUBF=63.05,FLD=34 ; preliminary virus comment

 I FILE=63.1 S SUBF=63.05,FLD=15 ; preliminary parasite comment

 I FILE=63.11 S SUBF=63.05,FLD=19 ; preliminary mycology comment

 I FILE=63.18 S SUBF=63.05,FLD=23 ; preliminary TB comment

 I FILE=63.061 S SUBF=63.05,FLD=11.5 ; bacteria tests

 I FILE=63.361 S SUBF=63.05,FLD=15 ; parasitology tests

 I FILE=63.111 S SUBF=63.05,FLD=19 ; mycology tests

 I FILE=63.181 S SUBF=63.05,FLD=23 ; TB tests

 I FILE=63.432 S SUBF=63.05,FLD=34 ; virology tests

 I FILE=63.292 S SUBF=63.05,FLD=11.5 ; sterility tests

 ;

 I FLD,SUBF D BLDSTAT^LRVRMI4A(SUBF,FLD,STAT,.LRSTATUS)

 ;

 Q

 ;

 ;

RPTDT(LRDFN,LRIDT,SUBSCR,RPTDT,USER) ; File Report Approved Date and Person Reporting

 ; Inputs

 ;  LRDFN: LRDFN

 ;  LRIDT: LRIDT

 ; SUBSCR: MI Result Subscript (eg 19,21,23,24,25,26)

 ;  RPTDT: Report Approved Date/Time

 ;   USER: Person Reporting (#200)

 ; Outputs

 ;  Returns 0^ErrNum^ErrMsg on error, 1 on success

 N DIERR,FLDS,IEN,LRFDA,LRMSG,LRX

 ;

 S LRDFN=$G(LRDFN),LRIDT=$G(LRIDT),SUBSCR=$G(SUBSCR),(FLDS,LRX)=""

 ;

 I $G(RPTDT)'>0 S RPTDT=$$NOW^XLFDT()

 I $G(USER)="" S USER=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))

 I LRDFN,LRIDT,SUBSCR S FLDS=$$NODE2FLD(SUBSCR)

 ;

 I FLDS'="" D

 . S IEN=LRIDT_","_LRDFN_","

 . I LRINTYPE=10 S LRFDA(1,63.05,IEN,$P(FLDS,"^",1))=RPTDT

 . S LRFDA(1,63.05,IEN,$P(FLDS,"^",2))=USER

 . D FILE^DIE("","LRFDA(1)","LRMSG")

 . I '$D(LRMSG) S LRX=1,LRRPTAPP=1 Q

 . S LRX="0^2^FileMan error"

 E  S LRX="0^1^No Field #s found"

 ;

 Q LRX

 ;

 ;

NODE2FLD(NODE) ; Resolve the fields to update based on the node

 ; Call with NODE = node in MI subscript to process

 ;

 ; Returns FIELDS = Report Date Approved^Person Reporting field #s

 ;

 N FIELDS

 S NODE=$G(NODE),FIELDS=""

 ;

 I NODE'="" D

 . I NODE?1(1"19",1"25",1"26",1"31") S FIELDS="11^11.55" Q

 . I NODE?1(1"23",1"29") S FIELDS="22^25.5" Q

 . I NODE?1(1"21",1"24",1"27") S FIELDS="14^15.5" Q

 . I NODE?1(1"15",1"22",1"28") S FIELDS="18^19.5" Q

 . I NODE?1(1"20",1"30") S FIELDS="33^35" Q

 ;

 Q FIELDS

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRVRMI3   6159     printed  Mar 13, 2025@21:27:21                                                                                                                                                                                                     Page 2

LRVRMI3   ;DALOI/STAFF - LAB MICRO LEDI INTERFACE ;09/07/16  08:09

 +1       ;;5.2;LAB SERVICE;**350,427,453,474**;Sep 27, 1994;Build 14

 +2       ;

 +3       ; Part of Micro LEDI interface.  It is a continuation of ^LRVRMI4 and ^LRVRMI2. Processes data in the temp global ^TMP("LRMI")

 +4       ; and stores it into the appropriate sections of the Lab Data Microbiology file (#63.05).

 +5       ;

 +6       ;

NODE(LRNODE) ;  Process similar multiples - nodes 15,19-31

 +1       ; Call with LRNODE = node in MI subscript to process

 +2       ;

 +3        NEW DIERR,IEN,LRCMT,LRFDA,LRFDAIEN,LRFILE,LRERR,LRIEN,LRMSG,LRPL,LRX,X

 +4       ; Mycology smear/prep^^^^Preliminary bacteriology comment^Preliminary virology comment^Preliminary parasite comment^Preliminary mycology comment^Preliminary TB comment^

 +5       ; Parasitology smear/prep^Bacteriology smear/prep^Bacteriology test^Parasite test^Mycology test^TB test^Virology test^Sterility test

 +6       ;

 +7        SET LRFILE=$PIECE("63.371^^^^63.06^63.431^63.1^63.11^63.18^63.341^63.291^63.061^63.361^63.111^63.181^63.432^63.292^","^",LRNODE-14)

 +8        MERGE LRCMT=^LR(LRDFN,"MI",LRIDT,LRNODE)

 +9       ;

 +10       SET IEN=0

 +11       FOR 

               SET IEN=$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,LRNODE,IEN))

               if IEN<1

                   QUIT 

               Begin DoDot:1

 +12               SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,LRNODE,IEN,0))

                   SET LRX=$SELECT(LRX'="":LRX,1:" ")

 +13               IF LRX'=" "

                       IF $$DUPCHK^LRVRMI3(LRLL,LRPROF,.LRCMT,LRX)

                           QUIT 

 +14               SET LRFDA(1,LRFILE,"+"_IEN_","_LRIDT_","_LRDFN_",",.01)=LRX

 +15      ;S LRFDAIEN(IEN)=IEN

 +16      ;

 +17      ; if result came across in NTE, PL and status info will be under ^(0) node

 +18      ;

                   IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,LRNODE,0))

                       Begin DoDot:2

 +19                       SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,LRNODE,0))

 +20                       SET X=$PIECE(LRX,"^",4)

 +21                       DO STAT4CMT(LRFILE,X,.LRSTATUS)

 +22                       IF $PIECE(LRX,"^")

                               SET LRPL(IEN)=$PIECE(LRX,"^")

                       End DoDot:2

 +23      ;

 +24      ; if result came across in OBX, PL and status info will be under ^(IEN,0,0) node

 +25      ;

                   IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,LRNODE,IEN,0,0))

                       Begin DoDot:2

 +26                       SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,LRNODE,IEN,0,0))

 +27                       SET X=$PIECE(LRX,"^",4)

 +28                       DO STAT4CMT(LRFILE,X,.LRSTATUS)

 +29                       IF $PIECE(LRX,"^")

                               SET LRPL(IEN)=$PIECE(LRX,"^")

                       End DoDot:2

 +30      ;

               End DoDot:1

 +31      ;

 +32       IF '$DATA(LRFDA)

               QUIT 

 +33      ;

 +34       DO UPDATE^DIE("","LRFDA(1)","LRFDAIEN","LRERR")

 +35       SET IEN=0

 +36       FOR 

               SET IEN=$ORDER(LRPL(IEN))

               if 'IEN

                   QUIT 

               Begin DoDot:1

 +37               IF $GET(LRFDAIEN(IEN))

                       DO SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_","_LRNODE_","_LRFDAIEN(IEN),LRPL(IEN))

               End DoDot:1

 +38      ;

 +39      ;

 +40      ; Update d/t approved and user approving

 +41       SET LRX=$$RPTDT(LRDFN,LRIDT,LRNODE,LRNOW,$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ)))

 +42      ;

 +43       QUIT 

 +44      ;

 +45      ;

SETPL(NODE) ; Setup LRPL array

 +1       ; Call with NODE = node in MI subscript to retrieve the performing lab

 +2       ;

 +3        NEW LRX

 +4        SET LRX=^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,NODE,IEN,0,0)

 +5        IF $PIECE(LRX,"^")

               SET LRPL(IEN)=$PIECE(LRX,"^")

 +6        QUIT 

 +7       ;

 +8       ;

STOREPL(NODE) ; Set performing lab

 +1       ; Call with NODE = node in MI subscript to retrieve the performing lab

 +2        NEW IEN

 +3        SET IEN=0

 +4        FOR 

               SET IEN=$ORDER(LRPL(IEN))

               if 'IEN

                   QUIT 

               IF $GET(LRFDAIEN(IEN))

                   DO SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_","_NODE_","_LRFDAIEN(IEN),LRPL(IEN))

 +5        QUIT 

 +6       ;

 +7       ;

DUPCHK(LRLL,LRPROF,LRCMT,LRCOM) ; Check for duplicates - comment stripped if spaces, force to upper case unless

 +1       ; flag set to store duplicates (Field #2.2 of PROFILE multiple in file #68.2)

 +2       ;

 +3       ; Call with  LRLL = load/work list ien

 +4       ;          LRPROF = profile ien in load/worklist

 +5       ;           LRCMT = array containing current comments on file

 +6       ;           LRCOM = new comment to check

 +7       ;

 +8       ; Returns LRDUP = 0 (no duplicate), 1 (duplicate)

 +9       ;

 +10       NEW LRDUP,LRI,LRX,LRY

 +11       SET LRDUP=0

 +12       IF '$PIECE($GET(^LRO(68.2,LRLL,10,+$GET(LRPROF),0)),U,4)

               Begin DoDot:1

 +13               SET LRI=0

                   SET LRY=$TRANSLATE(LRCOM," ","")

                   SET LRY=$$UP^XLFSTR(LRY)

 +14               FOR 

                       SET LRI=$ORDER(LRCMT(LRI))

                       if 'LRI

                           QUIT 

                       Begin DoDot:2

 +15                       SET LRX=$PIECE(LRCMT(LRI,0),U)

                           SET LRX=$TRANSLATE(LRX," ","")

                           SET LRX=$$UP^XLFSTR(LRX)

 +16                       IF LRX=LRY

                               SET LRDUP=1

                       End DoDot:2

                       if LRDUP

                           QUIT 

               End DoDot:1

 +17       QUIT LRDUP

 +18      ;

 +19      ;

STAT4CMT(FILE,STAT,LRSTATUS) ; Calculate status for comment nodes (eg BACT SMEAR)

 +1       ; Inputs

 +2       ;       FILE: The file # of the comment field in #63.

 +3       ;       STAT: The status (eg F)

 +4       ;   LRSTATUS:<byref>  Input and Output

 +5       ; Outputs

 +6       ;   LRSTATUS:

 +7        NEW SUBF,FLD

 +8        SET (FLD,SUBF)=""

 +9       ;

 +10      ; Bact Smear

           IF FILE=63.291

               SET SUBF=63.05

               SET FLD=11.5

 +11      ; Para Smear

           IF FILE=63.341

               SET SUBF=63.05

               SET FLD=15

 +12      ; Myco Smear

           IF FILE=63.371

               SET SUBF=63.05

               SET FLD=19

 +13      ; preliminary bacteria comment

           IF FILE=63.06

               SET SUBF=63.05

               SET FLD=11.5

 +14      ; preliminary virus comment

           IF FILE=63.431

               SET SUBF=63.05

               SET FLD=34

 +15      ; preliminary parasite comment

           IF FILE=63.1

               SET SUBF=63.05

               SET FLD=15

 +16      ; preliminary mycology comment

           IF FILE=63.11

               SET SUBF=63.05

               SET FLD=19

 +17      ; preliminary TB comment

           IF FILE=63.18

               SET SUBF=63.05

               SET FLD=23

 +18      ; bacteria tests

           IF FILE=63.061

               SET SUBF=63.05

               SET FLD=11.5

 +19      ; parasitology tests

           IF FILE=63.361

               SET SUBF=63.05

               SET FLD=15

 +20      ; mycology tests

           IF FILE=63.111

               SET SUBF=63.05

               SET FLD=19

 +21      ; TB tests

           IF FILE=63.181

               SET SUBF=63.05

               SET FLD=23

 +22      ; virology tests

           IF FILE=63.432

               SET SUBF=63.05

               SET FLD=34

 +23      ; sterility tests

           IF FILE=63.292

               SET SUBF=63.05

               SET FLD=11.5

 +24      ;

 +25       IF FLD

               IF SUBF

                   DO BLDSTAT^LRVRMI4A(SUBF,FLD,STAT,.LRSTATUS)

 +26      ;

 +27       QUIT 

 +28      ;

 +29      ;

RPTDT(LRDFN,LRIDT,SUBSCR,RPTDT,USER) ; File Report Approved Date and Person Reporting

 +1       ; Inputs

 +2       ;  LRDFN: LRDFN

 +3       ;  LRIDT: LRIDT

 +4       ; SUBSCR: MI Result Subscript (eg 19,21,23,24,25,26)

 +5       ;  RPTDT: Report Approved Date/Time

 +6       ;   USER: Person Reporting (#200)

 +7       ; Outputs

 +8       ;  Returns 0^ErrNum^ErrMsg on error, 1 on success

 +9        NEW DIERR,FLDS,IEN,LRFDA,LRMSG,LRX

 +10      ;

 +11       SET LRDFN=$GET(LRDFN)

           SET LRIDT=$GET(LRIDT)

           SET SUBSCR=$GET(SUBSCR)

           SET (FLDS,LRX)=""

 +12      ;

 +13       IF $GET(RPTDT)'>0

               SET RPTDT=$$NOW^XLFDT()

 +14       IF $GET(USER)=""

               SET USER=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))

 +15       IF LRDFN

               IF LRIDT

                   IF SUBSCR

                       SET FLDS=$$NODE2FLD(SUBSCR)

 +16      ;

 +17       IF FLDS'=""

               Begin DoDot:1

 +18               SET IEN=LRIDT_","_LRDFN_","

 +19               IF LRINTYPE=10

                       SET LRFDA(1,63.05,IEN,$PIECE(FLDS,"^",1))=RPTDT

 +20               SET LRFDA(1,63.05,IEN,$PIECE(FLDS,"^",2))=USER

 +21               DO FILE^DIE("","LRFDA(1)","LRMSG")

 +22               IF '$DATA(LRMSG)

                       SET LRX=1

                       SET LRRPTAPP=1

                       QUIT 

 +23               SET LRX="0^2^FileMan error"

               End DoDot:1

 +24      IF '$TEST

               SET LRX="0^1^No Field #s found"

 +25      ;

 +26       QUIT LRX

 +27      ;

 +28      ;

NODE2FLD(NODE) ; Resolve the fields to update based on the node

 +1       ; Call with NODE = node in MI subscript to process

 +2       ;

 +3       ; Returns FIELDS = Report Date Approved^Person Reporting field #s

 +4       ;

 +5        NEW FIELDS

 +6        SET NODE=$GET(NODE)

           SET FIELDS=""

 +7       ;

 +8        IF NODE'=""

               Begin DoDot:1

 +9                IF NODE?1(1"19",1"25",1"26",1"31")

                       SET FIELDS="11^11.55"

                       QUIT 

 +10               IF NODE?1(1"23",1"29")

                       SET FIELDS="22^25.5"

                       QUIT 

 +11               IF NODE?1(1"21",1"24",1"27")

                       SET FIELDS="14^15.5"

                       QUIT 

 +12               IF NODE?1(1"15",1"22",1"28")

                       SET FIELDS="18^19.5"

                       QUIT 

 +13               IF NODE?1(1"20",1"30")

                       SET FIELDS="33^35"

                       QUIT 

               End DoDot:1

 +14      ;

 +15       QUIT FIELDS