ABMUPTIN.m

ABMUPTIN ; IHS/SD/SDR - 3PB/UFMS Pseudo TIN report   

 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009

 ;

 ; New routine - v2.5 p12 SDD item 4.9.3.1

 ;

EP ;

 S DIR(0)="S^B:Billing Address;M:Mailing Address"

 S DIR("A")="Which address would you like to see on the report"

 D ^DIR

 G:$D(DIROUT)!$D(DTOUT)!$D(DUOUT)!$D(DIRUT) XIT

 S ABMADD=Y

 S ABM("HD",0)="===== INSURER LISTING WITH PSEUDO TINS ====="

 S ABMY("LOC")=DUZ(2)

 S ABM("LVL")=0

 S ABM("CONJ")=""

 S ABM("TXT")=""

 S ABM("PG")=1

 D LOC^ABMDRHD G XIT:'$D(IO)!$G(POP)!$D(DTOUT)!$D(DUOUT)

 S ABMQ("RX")="XIT^ABMUPTIN"

 S ABMQ("NS")="ABM"

 S ABMQ("RP")="COMPUTE^ABMUPTIN"

 D ^ABMDRDBQ

 Q

COMPUTE ;

 K DIC,DIE,X,Y,DA,ABMC,ABMI,ABMCNT

 S ABMI=0

 D WHD^ABMDRHD

 W !,?2,"INSURER",?35,$S(ABMADD="B":"BILLING",1:"MAILING")_" ADDRESS",?70,"TIN"

 W !?5,"Address",?37,"City",?53,"ST",?56,"Zip",?67,"Phone"

 W !

 F ABMI=1:1:80 W "-"

 S ABMI=0

 F  S ABMI=$O(^AUTNINS(ABMI)) Q:+ABMI=0  D

 .K ABMC

 .D GETS^DIQ("9999999.18",ABMI,".01;.02;.03;.04;.05;.06;.11;2;3;4;5","IE","ABMC")

 .S ABMTIN=$G(ABMC("9999999.18",ABMI_",",".11","E"))

 .Q:$A($E(ABMTIN,9))<65!($A($E(ABMTIN,9))>91)

 .W !?2,$E($G(ABMC("9999999.18",ABMI_",",".01","E")),1,30)

 .W ?70,$G(ABMC("9999999.18",ABMI_",",".11","E"))

 .W !

 .I ABMADD="M" D

 ..W ?5,$G(ABMC("9999999.18",ABMI_",",".02","E"))

 ..W ?37,$G(ABMC("9999999.18",ABMI_",",".03","E"))

 ..W ?53,$P($G(^DIC(5,$G(ABMC("9999999.18",ABMI_",",".04","I")),0)),U,2)

 ..W ?56,$G(ABMC("9999999.18",ABMI_",",".05","E"))

 ..W ?67,$G(ABMC("9999999.18",ABMI_",",".06","E"))

 .I ABMADD="B" D

 ..W ?5,$G(ABMC("9999999.18",ABMI_",","2","E"))

 ..W ?37,$G(ABMC("9999999.18",ABMI_",","3","E"))

 ..I $G(ABMC("9999999.18",ABMI_",","4","I"))'="" W ?53,$P($G(^DIC(5,$G(ABMC("9999999.18",ABMI_",","4","I")),0)),U,2)

 ..W ?56,$P($G(ABMC("9999999.18",ABMI_",","5","E")),"-")

 ..W ?67,$G(ABMC("9999999.18",ABMI_",",".06","E"))

 .S ABMCNT=+$G(ABMCNT)+1

 I +$G(ABMCNT)>0 D

 .W !!?40,"TOTAL INSURERS WITH PSEUDO TIN:  ",ABMCNT

 Q

XIT ;

 K ABMC,ABMADD,ABMI,ABMTIN

 Q

ABMUPTIN  ; IHS/SD/SDR - 3PB/UFMS Pseudo TIN report   

 +1       ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009

 +2       ;

 +3       ; New routine - v2.5 p12 SDD item 4.9.3.1

 +4       ;

EP        ;

 +1        SET DIR(0)="S^B:Billing Address;M:Mailing Address"

 +2        SET DIR("A")="Which address would you like to see on the report"

 +3        DO ^DIR

 +4        IF $DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)

               GOTO XIT

 +5        SET ABMADD=Y

 +6        SET ABM("HD",0)="===== INSURER LISTING WITH PSEUDO TINS ====="

 +7        SET ABMY("LOC")=DUZ(2)

 +8        SET ABM("LVL")=0

 +9        SET ABM("CONJ")=""

 +10       SET ABM("TXT")=""

 +11       SET ABM("PG")=1

 +12       DO LOC^ABMDRHD

           IF '$DATA(IO)!$GET(POP)!$DATA(DTOUT)!$DATA(DUOUT)

               GOTO XIT

 +13       SET ABMQ("RX")="XIT^ABMUPTIN"

 +14       SET ABMQ("NS")="ABM"

 +15       SET ABMQ("RP")="COMPUTE^ABMUPTIN"

 +16       DO ^ABMDRDBQ

 +17       QUIT 

COMPUTE   ;

 +1        KILL DIC,DIE,X,Y,DA,ABMC,ABMI,ABMCNT

 +2        SET ABMI=0

 +3        DO WHD^ABMDRHD

 +4        WRITE !,?2,"INSURER",?35,$SELECT(ABMADD="B":"BILLING",1:"MAILING")_" ADDRESS",?70,"TIN"

 +5        WRITE !?5,"Address",?37,"City",?53,"ST",?56,"Zip",?67,"Phone"

 +6        WRITE !

 +7        FOR ABMI=1:1:80

               WRITE "-"

 +8        SET ABMI=0

 +9        FOR 

               SET ABMI=$ORDER(^AUTNINS(ABMI))

               IF +ABMI=0

                   QUIT 

               Begin DoDot:1

 +10               KILL ABMC

 +11               DO GETS^DIQ("9999999.18",ABMI,".01;.02;.03;.04;.05;.06;.11;2;3;4;5","IE","ABMC")

 +12               SET ABMTIN=$GET(ABMC("9999999.18",ABMI_",",".11","E"))

 +13               IF $ASCII($EXTRACT(ABMTIN,9))<65!($ASCII($EXTRACT(ABMTIN,9))>91)

                       QUIT 

 +14               WRITE !?2,$EXTRACT($GET(ABMC("9999999.18",ABMI_",",".01","E")),1,30)

 +15               WRITE ?70,$GET(ABMC("9999999.18",ABMI_",",".11","E"))

 +16               WRITE !

 +17               IF ABMADD="M"

                       Begin DoDot:2

 +18                       WRITE ?5,$GET(ABMC("9999999.18",ABMI_",",".02","E"))

 +19                       WRITE ?37,$GET(ABMC("9999999.18",ABMI_",",".03","E"))

 +20                       WRITE ?53,$PIECE($GET(^DIC(5,$GET(ABMC("9999999.18",ABMI_",",".04","I")),0)),U,2)

 +21                       WRITE ?56,$GET(ABMC("9999999.18",ABMI_",",".05","E"))

 +22                       WRITE ?67,$GET(ABMC("9999999.18",ABMI_",",".06","E"))

                       End DoDot:2

 +23               IF ABMADD="B"

                       Begin DoDot:2

 +24                       WRITE ?5,$GET(ABMC("9999999.18",ABMI_",","2","E"))

 +25                       WRITE ?37,$GET(ABMC("9999999.18",ABMI_",","3","E"))

 +26                       IF $GET(ABMC("9999999.18",ABMI_",","4","I"))'=""

                               WRITE ?53,$PIECE($GET(^DIC(5,$GET(ABMC("9999999.18",ABMI_",","4","I")),0)),U,2)

 +27                       WRITE ?56,$PIECE($GET(ABMC("9999999.18",ABMI_",","5","E")),"-")

 +28                       WRITE ?67,$GET(ABMC("9999999.18",ABMI_",",".06","E"))

                       End DoDot:2

 +29               SET ABMCNT=+$GET(ABMCNT)+1

               End DoDot:1

 +30       IF +$GET(ABMCNT)>0

               Begin DoDot:1

 +31               WRITE !!?40,"TOTAL INSURERS WITH PSEUDO TIN:  ",ABMCNT

               End DoDot:1

 +32       QUIT 

XIT       ;

 +1        KILL ABMC,ABMADD,ABMI,ABMTIN

 +2        QUIT