BLRAGUT3.m

BLRAGUT3 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPC UTILITIES 3; 27-Jun-2016 08:52 ; MKK

 ;;5.2;IHS LABORATORY;**1039**;NOV 01, 1997;Build 38

 ;

RLALLTST(ORDERN) ; EP - Reference Lab ALL TeSTs

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ORDERN,U,XPARSYS,XQXFLG)

 ;

 S BLRDT=0

 F  S BLRDT=$O(^LRO(69,"C",ORDERN,BLRDT))  Q:BLRDT<1  D

 . S BLRSP=0

 . F  S BLRSP=$O(^LRO(69,"C",ORDERN,BLRDT,BLRSP))  Q:BLRSP<1  D

 .. S BLRTSN=0

 .. F  S BLRTSN=$O(^LRO(69,BLRDT,1,BLRSP,2,"B",BLRTSN))  Q:BLRTSN<1  D

 ... D REFLABS

 Q

 ;

 ;

REFLABS ; EP - Store Info into 9009026.3

 Q:+$P($G(^BLRSITE(DUZ(2),"RL")),U)<1    ; If not Ref Lab, don't store

 ;

 ; --- DEBUG START

 D

 . NEW TMPBLRRF

 . ; M TMPBLRRF=^TMP("BLRRL",$J)

 . ; D FORCEIT^BLRUTIL7("REFLABS^BLRAGUT3 0.0")

 ; --- DEBUG END

 ;

 NEW AGINS,BDA,BDAC,BLRSEQ,DFN,ERRS,FDA,INSS,LRDFN,LROIEN,ORDIEN,PLCYHLDR,POLICYN,REFLORDN

 ;

 S LROIEN=BLRSP_","_BLRDT

 S REFLORDN=+$$GET1^DIQ(69.01,LROIEN,9.5,"I")

 Q:REFLORDN<1

 ;

 S LRDFN=$$GET1^DIQ(69.01,LROIEN,.01,"I")

 S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")

 ;

 S X=$$ORD^BLRRLEDI(REFLORDN,DFN)     ; Create entry in 9009026.3, if necessary

 S ORDIEN=$$FIND1^DIC(9009026.3,,,REFLORDN)

 Q:ORDIEN<1     ; Quit if Order # NOT in 9009026.3

 ;

 S PLCYHLDR=+$O(^AUPN3PPH("C",DFN,"A"),-1)     ; PoLiCY HoLDeR

 S POLICYN=$$GET1^DIQ(9000003.1,PLCYHLDR,.04,"I")  ; POLICY Number

 ;

 I $L($G(BLRRL("CLIENT"))) S FDA(9009026.3,ORDIEN_",",.03)=$G(BLRRL("CLIENT"))

 E  S:POLICYN FDA(9009026.3,ORDIEN_",",.03)=POLICYN

 S FDA(9009026.3,ORDIEN_",",.05)=BLRBT

 ;

 D UPDATE^DIE(,"FDA",,"ERRS")

 ;

 D STUFFINS(DFN,REFLORDN)

 ; D FORCEIT^BLRUTIL7("REFLABS^BLRAGUT 9.0","BLRRL")

 ; D SETINS^BLRAG05C

 Q

 ;

STUFFINS(DFN,OR) ; "Stuff Insurance" -- OR = Order Number

 ; NEW (BLRDT,BLRSP,DILOCKTM,DISYS,DFN,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,OR,PAT,U,XPARSYS,XQXFLG)

 S BDAC=0

 D ^AGINS

 Q:'$D(AGINS(1))   ; Patient has No Insurance on file

 ;

 D SEQINS^BLRRLEDI(.AGINS,DFN,DT)

 S BDA=0 F  S BDA=$O(BLRSEQ(BDA)) Q:'BDA!(BDAC>3)  D

 . S BDAC=BDAC+1

 . S INSS=$TR($G(BLRSEQ(BDA)),"^","~")  ;have to switch to ~ for filing

 . D UPINS^BLRRLEDI(OR,"",DFN,INSS)

 Q

BLRAGUT3  ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPC UTILITIES 3; 27-Jun-2016 08:52 ; MKK

 +1       ;;5.2;IHS LABORATORY;**1039**;NOV 01, 1997;Build 38

 +2       ;

RLALLTST(ORDERN) ; EP - Reference Lab ALL TeSTs

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ORDERN,U,XPARSYS,XQXFLG)

 +2       ;

 +3        SET BLRDT=0

 +4        FOR 

               SET BLRDT=$ORDER(^LRO(69,"C",ORDERN,BLRDT))

               IF BLRDT<1

                   QUIT 

               Begin DoDot:1

 +5                SET BLRSP=0

 +6                FOR 

                       SET BLRSP=$ORDER(^LRO(69,"C",ORDERN,BLRDT,BLRSP))

                       IF BLRSP<1

                           QUIT 

                       Begin DoDot:2

 +7                        SET BLRTSN=0

 +8                        FOR 

                               SET BLRTSN=$ORDER(^LRO(69,BLRDT,1,BLRSP,2,"B",BLRTSN))

                               IF BLRTSN<1

                                   QUIT 

                               Begin DoDot:3

 +9                                DO REFLABS

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10       QUIT 

 +11      ;

 +12      ;

REFLABS   ; EP - Store Info into 9009026.3

 +1       ; If not Ref Lab, don't store

           IF +$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U)<1

               QUIT 

 +2       ;

 +3       ; --- DEBUG START

 +4        Begin DoDot:1

 +5            NEW TMPBLRRF

 +6       ; M TMPBLRRF=^TMP("BLRRL",$J)

 +7       ; D FORCEIT^BLRUTIL7("REFLABS^BLRAGUT3 0.0")

           End DoDot:1

 +8       ; --- DEBUG END

 +9       ;

 +10       NEW AGINS,BDA,BDAC,BLRSEQ,DFN,ERRS,FDA,INSS,LRDFN,LROIEN,ORDIEN,PLCYHLDR,POLICYN,REFLORDN

 +11      ;

 +12       SET LROIEN=BLRSP_","_BLRDT

 +13       SET REFLORDN=+$$GET1^DIQ(69.01,LROIEN,9.5,"I")

 +14       IF REFLORDN<1

               QUIT 

 +15      ;

 +16       SET LRDFN=$$GET1^DIQ(69.01,LROIEN,.01,"I")

 +17       SET DFN=$$GET1^DIQ(63,LRDFN,.03,"I")

 +18      ;

 +19      ; Create entry in 9009026.3, if necessary

           SET X=$$ORD^BLRRLEDI(REFLORDN,DFN)

 +20       SET ORDIEN=$$FIND1^DIC(9009026.3,,,REFLORDN)

 +21      ; Quit if Order # NOT in 9009026.3

           IF ORDIEN<1

               QUIT 

 +22      ;

 +23      ; PoLiCY HoLDeR

           SET PLCYHLDR=+$ORDER(^AUPN3PPH("C",DFN,"A"),-1)

 +24      ; POLICY Number

           SET POLICYN=$$GET1^DIQ(9000003.1,PLCYHLDR,.04,"I")

 +25      ;

 +26       IF $LENGTH($GET(BLRRL("CLIENT")))

               SET FDA(9009026.3,ORDIEN_",",.03)=$GET(BLRRL("CLIENT"))

 +27      IF '$TEST

               IF POLICYN

                   SET FDA(9009026.3,ORDIEN_",",.03)=POLICYN

 +28       SET FDA(9009026.3,ORDIEN_",",.05)=BLRBT

 +29      ;

 +30       DO UPDATE^DIE(,"FDA",,"ERRS")

 +31      ;

 +32       DO STUFFINS(DFN,REFLORDN)

 +33      ; D FORCEIT^BLRUTIL7("REFLABS^BLRAGUT 9.0","BLRRL")

 +34      ; D SETINS^BLRAG05C

 +35       QUIT 

 +36      ;

STUFFINS(DFN,OR) ; "Stuff Insurance" -- OR = Order Number

 +1       ; NEW (BLRDT,BLRSP,DILOCKTM,DISYS,DFN,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,OR,PAT,U,XPARSYS,XQXFLG)

 +2        SET BDAC=0

 +3        DO ^AGINS

 +4       ; Patient has No Insurance on file

           IF '$DATA(AGINS(1))

               QUIT 

 +5       ;

 +6        DO SEQINS^BLRRLEDI(.AGINS,DFN,DT)

 +7        SET BDA=0

           FOR 

               SET BDA=$ORDER(BLRSEQ(BDA))

               IF 'BDA!(BDAC>3)

                   QUIT 

               Begin DoDot:1

 +8                SET BDAC=BDAC+1

 +9       ;have to switch to ~ for filing

                   SET INSS=$TRANSLATE($GET(BLRSEQ(BDA)),"^","~")

 +10               DO UPINS^BLRRLEDI(OR,"",DFN,INSS)

               End DoDot:1

 +11       QUIT