Routine: BLRSHPL2

BLRSHPL2 ;cmi/anch/maw - BLR Reference Lab Shipping Manifest: Others ; 20-May-2016 07:17 ; MKK

 ;;5.2;IHS LABORATORY;**1027,1028,1031,1034,1039**;NOV 01, 1997;Build 38

WA ;-- print labcorp written authorization

 W !!

 W "I hereby authorize the release of medical information related to the services"

 W !,"described herein and authorize payment directly to Laboratory Corporation of"

 W !,"America.  I agree to assume responsibility for payment of charges for"

 W !,"laboratory services that are not covered by any healthcare insurer."

 W !!!

 W "____________________  __________",?40,"___________________  __________"

 W !,"Patient Signature     Date",?40,"Physician Signature  Date"

PRTSECI(SEC,PT) ;-- print the secondary insurance

 N INSI,ICC,IN,IR,IRE,INRN,INRA,INRAE,INSAD,INSADE,GUARI,GUAR,GUARA,GUARAE,GUARPH,ING,INID,GUARP

 N INST

 S INSI=$P(SEC,U,2)

 S ICC=$TR($P($G(^AUTNINS(INSI,2)),U,19),"~")

 S IR=$S($P(SEC,U,16):$P($G(^AUTTRLSH($P(SEC,U,16),0)),U),1:"")

 I $G(IR)]"" D

 . I IR="SELF" S IR=1 Q

 . I IR="SPOUSE" S IR=2,IRE="SPOUSE" Q

 . I IR="HUSBAND" S IR=2,IRE="SPOUSE" Q

 . I IR="WIFE" S IR=2,IRE="SPOUSE" Q

 . S IR=3,IRE="OTHER" Q

 I $G(IR)="" S IR=1,IRE="SELF"

 S INRN=$P($G(^AUTNINS(INSI,0)),U)

 S INRA=$$PATADD^BLRRLHL(PT)

 S INRAE=$TR($P($$PATADD^BLRRLHL(PT),U),U," ")_"~"_$TR($P($$PATADD^BLRRLHL(PT),U,3,99),U," ")

 S INSAD=$$INSADD^BLRRLHL(INSI)

 S INSADE=$TR($P(INSAD,U),U," ")_"~"_$TR($P(INSAD,U,3,99),U," ")

 S GUARI=$P(SEC,U,7)

 S INST=$P($G(^AUTNINS(INSI,2)),U)

 I $E(GUARI,1,1)="P" D

 . S GUAR=$$HLNAME^XLFNAME($P(^AUPN3PPH($E(GUARI,2,99),0),U))

 . S GUARAD=$$GT1ADD^BLRRLHL($E(GUARI,2,99))

 . S GUARPH=$P($G(^AUPN3PPH($E(GUARI,2,99),0)),U,14)

 . ;D INSTYP(BLRTSTDA)

 . S GUARAE=$TR($P($G(GUARA),U),U," ")_"~"_$TR($P($G(GUARA),U,3,99),U," ")

 . S GUARE=$TR($G(GUAR),U," ")

 I GUARI]"",$E(GUARI,1,1)'="P" D

 . S GUAR=$P(^DPT(PT,0),U)

 . S GUARA=$$PATADD^BLRRLHL(PT)

 . S GUARPH=$P($G(^DPT(PT,.131)),U)

 I GUAR="" D

 . S GUAR=$P($G(^DPT(PT,0)),U)

 . S GUARA=$G(INRAE)

 ;D INSTYP(BLRTSTDA)

 S GUARAE=$TR($P($G(GUARA),U),U," ")_"~"_$TR($P($G(GUARA),U,3,99),U," ")

 S GUARE=$TR($G(GUAR),U," ")

 S ING=$P(SEC,U,20)

 S INID=$P(SEC,U,9)

 W !!,"SECONDARY INSURANCE"

 W !,"Ins Carrier Code: "_$G(ICC),?40,"Insured Name: "_$E($P($G(^DPT(PT,0)),U),1,26)

 W !,?40,"Relationship: "_$G(IRE)

 W !,"Insurer Name: ",$E($G(INRN),1,30),?40,"Insured Add: "_$P(INRAE,"~")

 W !,"Insurer Add: ",?54,$P(INRAE,"~",2)

 W !,$P($G(INSADE),"~"),?40,"Guarantor: "_$E($G(GUARE),1,25)

 W !,$P($G(INSADE),"~",2),?40,"Guar Add: "_$P($G(GUARAE),"~")

 W !,"Insurer Group: "_$G(ING),?50,$P($G(GUARE),"~",2)

 W !,"Insured ID: "_$G(INID),?40,"Guarantor Phone: "_$G(GUARPH)

BLRSHPL2  ;cmi/anch/maw - BLR Reference Lab Shipping Manifest: Others ; 20-May-2016 07:17 ; MKK

 +1       ;;5.2;IHS LABORATORY;**1027,1028,1031,1034,1039**;NOV 01, 1997;Build 38

 +2       ;

 +3       ;

 +4       ;

WA        ;-- print labcorp written authorization

 +1        WRITE !!

 +2        WRITE "I hereby authorize the release of medical information related to the services"

 +3        WRITE !,"described herein and authorize payment directly to Laboratory Corporation of"

 +4        WRITE !,"America.  I agree to assume responsibility for payment of charges for"

 +5        WRITE !,"laboratory services that are not covered by any healthcare insurer."

 +6        WRITE !!!

 +7        WRITE "____________________  __________",?40,"___________________  __________"

 +8        WRITE !,"Patient Signature     Date",?40,"Physician Signature  Date"

 +9        QUIT

 +10      ;

PRTSECI(SEC,PT) ;-- print the secondary insurance

 +1        NEW INSI,ICC,IN,IR,IRE,INRN,INRA,INRAE,INSAD,INSADE,GUARI,GUAR,GUARA,GUARAE,GUARPH,ING,INID,GUARP

 +2        NEW INST

 +3        SET INSI=$PIECE(SEC,U,2)

 +4        SET ICC=$TRANSLATE($PIECE($GET(^AUTNINS(INSI,2)),U,19),"~")

 +5        SET IR=$SELECT($PIECE(SEC,U,16):$PIECE($GET(^AUTTRLSH($PIECE(SEC,U,16),0)),U),1:"")

 +6        IF $GET(IR)]""

               Begin DoDot:1

 +7                IF IR="SELF"

                       SET IR=1

                       QUIT

 +8                IF IR="SPOUSE"

                       SET IR=2

                       SET IRE="SPOUSE"

                       QUIT

 +9                IF IR="HUSBAND"

                       SET IR=2

                       SET IRE="SPOUSE"

                       QUIT

 +10               IF IR="WIFE"

                       SET IR=2

                       SET IRE="SPOUSE"

                       QUIT

 +11               SET IR=3

                   SET IRE="OTHER"

                   QUIT

               End DoDot:1

 +12       IF $GET(IR)=""

               SET IR=1

               SET IRE="SELF"

 +13       SET INRN=$PIECE($GET(^AUTNINS(INSI,0)),U)

 +14       SET INRA=$$PATADD^BLRRLHL(PT)

 +15       SET INRAE=$TRANSLATE($PIECE($$PATADD^BLRRLHL(PT),U),U," ")_"~"_$TRANSLATE($PIECE($$PATADD^BLRRLHL(PT),U,3,99),U," ")

 +16       SET INSAD=$$INSADD^BLRRLHL(INSI)

 +17       SET INSADE=$TRANSLATE($PIECE(INSAD,U),U," ")_"~"_$TRANSLATE($PIECE(INSAD,U,3,99),U," ")

 +18       SET GUARI=$PIECE(SEC,U,7)

 +19       SET INST=$PIECE($GET(^AUTNINS(INSI,2)),U)

 +20       IF $EXTRACT(GUARI,1,1)="P"

               Begin DoDot:1

 +21               SET GUAR=$$HLNAME^XLFNAME($PIECE(^AUPN3PPH($EXTRACT(GUARI,2,99),0),U))

 +22               SET GUARAD=$$GT1ADD^BLRRLHL($EXTRACT(GUARI,2,99))

 +23               SET GUARPH=$PIECE($GET(^AUPN3PPH($EXTRACT(GUARI,2,99),0)),U,14)

 +24      ;D INSTYP(BLRTSTDA)

 +25               SET GUARAE=$TRANSLATE($PIECE($GET(GUARA),U),U," ")_"~"_$TRANSLATE($PIECE($GET(GUARA),U,3,99),U," ")

 +26               SET GUARE=$TRANSLATE($GET(GUAR),U," ")

               End DoDot:1

 +27       IF GUARI]""

               IF $EXTRACT(GUARI,1,1)'="P"

                   Begin DoDot:1

 +28                   SET GUAR=$PIECE(^DPT(PT,0),U)

 +29                   SET GUARA=$$PATADD^BLRRLHL(PT)

 +30                   SET GUARPH=$PIECE($GET(^DPT(PT,.131)),U)

                   End DoDot:1

 +31       IF GUAR=""

               Begin DoDot:1

 +32               SET GUAR=$PIECE($GET(^DPT(PT,0)),U)

 +33               SET GUARA=$GET(INRAE)

               End DoDot:1

 +34      ;D INSTYP(BLRTSTDA)

 +35       SET GUARAE=$TRANSLATE($PIECE($GET(GUARA),U),U," ")_"~"_$TRANSLATE($PIECE($GET(GUARA),U,3,99),U," ")

 +36       SET GUARE=$TRANSLATE($GET(GUAR),U," ")

 +37       SET ING=$PIECE(SEC,U,20)

 +38       SET INID=$PIECE(SEC,U,9)

 +39       WRITE !!,"SECONDARY INSURANCE"

 +40       WRITE !,"Ins Carrier Code: "_$GET(ICC),?40,"Insured Name: "_$EXTRACT($PIECE($GET(^DPT(PT,0)),U),1,26)

 +41       WRITE !,?40,"Relationship: "_$GET(IRE)

 +42       WRITE !,"Insurer Name: ",$EXTRACT($GET(INRN),1,30),?40,"Insured Add: "_$PIECE(INRAE,"~")

 +43       WRITE !,"Insurer Add: ",?54,$PIECE(INRAE,"~",2)

 +44       WRITE !,$PIECE($GET(INSADE),"~"),?40,"Guarantor: "_$EXTRACT($GET(GUARE),1,25)

 +45       WRITE !,$PIECE($GET(INSADE),"~",2),?40,"Guar Add: "_$PIECE($GET(GUARAE),"~")

 +46       WRITE !,"Insurer Group: "_$GET(ING),?50,$PIECE($GET(GUARE),"~",2)

 +47       WRITE !,"Insured ID: "_$GET(INID),?40,"Guarantor Phone: "_$GET(GUARPH)

 +48       QUIT

BLRSHPL2.m