IB20P361.m

IB20P361 ;BP/TJH - Preinit routine for IB*2.0*361 ; 12/14/2006

 ;;2.0;INTEGRATED BILLING;**361**;21-MAR-94;Build 9

 ;

 Q

EN ; entry point

 D ERRCD

 D SEXFILL

 Q

 ;

ERRCD ; add new error codes to 350.8

 N DO,DA,DIC,DIK,IBA,IBC,IBT,IBX,X,Y

 ;

 S IBC=0,(DIC,DIK)="^IBE(350.8,",DIC(0)=""

 F IBX=1:1 S IBT=$P($T(TXT+IBX),";",3) Q:'$L(IBT)  D

 . Q:$D(^IBE(350.8,"AC",$P(IBT,"^",3)))  ;  already on file

 . K DO

 . S X=$P(IBT,"^")

 . D FILE^DICN I Y>0 S ^IBE(350.8,+Y,0)=IBT,DA=+Y,IBC=IBC+1 D IX^DIK

 ;

 S IBA(2)="     "_IBC_" entries added to 350.8"

 S (IBA(1),IBA(3))=""

 ;

ERRCDX ;

 D MES^XPDUTL(.IBA)

 Q

 ;

SEXFILL ; fill INSURED'S SEX field with value where possible

 D BMES^XPDUTL(" Starting update of new INSURED'S SEX field for all existing policies.")

 D MES^XPDUTL(" . . . . . . .")

 N IBDFN,IBDA,IBVTSX,IBSPSX,IBWHOSE,START,PCTR,END,TT,MIN,SEC,MSG

T1 S START=$H,PCTR=0

 S IBDFN=0

 F  S IBDFN=$O(^DPT(IBDFN)) Q:'IBDFN  D

 . S PCTR=PCTR+1

 . Q:'$D(^DPT(IBDFN,.312))  ; no insurance to process

 . S IBVTSX=$P(^DPT(IBDFN,0),U,2) ; get veteran's sex

 . S IBSPSX=$TR(IBVTSX,"MF","FM") ; compute a spouse's sex in case it is needed

 . S IBDA=0

 . F  S IBDA=$O(^DPT(IBDFN,.312,IBDA)) Q:'IBDA  D

 .. S IBWHOSE=$P($G(^DPT(IBDFN,.312,IBDA,0)),U,6)

 .. Q:IBWHOSE=""  Q:'("sv"[IBWHOSE)  ; can't deal with anything but vet & spouse

 .. S $P(^DPT(IBDFN,.312,IBDA,3),U,12)=$S(IBWHOSE="v":IBVTSX,IBWHOSE="s":IBSPSX)

T2 S END=$H

 D BMES^XPDUTL(" INSURED'S SEX field update complete.")

 S TT=$P(END,",",2)-$P(START,",",2),MIN=TT\60,SEC=TT#60

 S MSG=" "_$FN(PCTR,",")_" patient records were processed in "_MIN_" minutes and "_SEC_" seconds."

 D BMES^XPDUTL(MSG)

 Q

TXT ; text of error messages to add

 ;;IB261^Primary insurance subscriber is missing INSURED'S SEX^IB261^1^1

 ;;IB262^Secondary insurance subscriber is missing INSURED'S SEX^IB262^1^1

 ;;IB263^Tertiary insurance subscriber is missing INSURED'S SEX^IB263^1^1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P361   1959     printed  Mar 13, 2025@21:07:08                                                                                                                                                                                                    Page 2

IB20P361  ;BP/TJH - Preinit routine for IB*2.0*361 ; 12/14/2006

 +1       ;;2.0;INTEGRATED BILLING;**361**;21-MAR-94;Build 9

 +2       ;

 +3        QUIT 

EN        ; entry point

 +1        DO ERRCD

 +2        DO SEXFILL

 +3        QUIT 

 +4       ;

ERRCD     ; add new error codes to 350.8

 +1        NEW DO,DA,DIC,DIK,IBA,IBC,IBT,IBX,X,Y

 +2       ;

 +3        SET IBC=0

           SET (DIC,DIK)="^IBE(350.8,"

           SET DIC(0)=""

 +4        FOR IBX=1:1

               SET IBT=$PIECE($TEXT(TXT+IBX),";",3)

               if '$LENGTH(IBT)

                   QUIT 

               Begin DoDot:1

 +5       ;  already on file

                   if $DATA(^IBE(350.8,"AC",$PIECE(IBT,"^",3)))

                       QUIT 

 +6                KILL DO

 +7                SET X=$PIECE(IBT,"^")

 +8                DO FILE^DICN

                   IF Y>0

                       SET ^IBE(350.8,+Y,0)=IBT

                       SET DA=+Y

                       SET IBC=IBC+1

                       DO IX^DIK

               End DoDot:1

 +9       ;

 +10       SET IBA(2)="     "_IBC_" entries added to 350.8"

 +11       SET (IBA(1),IBA(3))=""

 +12      ;

ERRCDX    ;

 +1        DO MES^XPDUTL(.IBA)

 +2        QUIT 

 +3       ;

SEXFILL   ; fill INSURED'S SEX field with value where possible

 +1        DO BMES^XPDUTL(" Starting update of new INSURED'S SEX field for all existing policies.")

 +2        DO MES^XPDUTL(" . . . . . . .")

 +3        NEW IBDFN,IBDA,IBVTSX,IBSPSX,IBWHOSE,START,PCTR,END,TT,MIN,SEC,MSG

T1         SET START=$HOROLOG

           SET PCTR=0

 +1        SET IBDFN=0

 +2        FOR 

               SET IBDFN=$ORDER(^DPT(IBDFN))

               if 'IBDFN

                   QUIT 

               Begin DoDot:1

 +3                SET PCTR=PCTR+1

 +4       ; no insurance to process

                   if '$DATA(^DPT(IBDFN,.312))

                       QUIT 

 +5       ; get veteran's sex

                   SET IBVTSX=$PIECE(^DPT(IBDFN,0),U,2)

 +6       ; compute a spouse's sex in case it is needed

                   SET IBSPSX=$TRANSLATE(IBVTSX,"MF","FM")

 +7                SET IBDA=0

 +8                FOR 

                       SET IBDA=$ORDER(^DPT(IBDFN,.312,IBDA))

                       if 'IBDA

                           QUIT 

                       Begin DoDot:2

 +9                        SET IBWHOSE=$PIECE($GET(^DPT(IBDFN,.312,IBDA,0)),U,6)

 +10      ; can't deal with anything but vet & spouse

                           if IBWHOSE=""

                               QUIT 

                           if '("sv"[IBWHOSE)

                               QUIT 

 +11                       SET $PIECE(^DPT(IBDFN,.312,IBDA,3),U,12)=$SELECT(IBWHOSE="v":IBVTSX,IBWHOSE="s":IBSPSX)

                       End DoDot:2

               End DoDot:1

T2         SET END=$HOROLOG

 +1        DO BMES^XPDUTL(" INSURED'S SEX field update complete.")

 +2        SET TT=$PIECE(END,",",2)-$PIECE(START,",",2)

           SET MIN=TT\60

           SET SEC=TT#60

 +3        SET MSG=" "_$FNUMBER(PCTR,",")_" patient records were processed in "_MIN_" minutes and "_SEC_" seconds."

 +4        DO BMES^XPDUTL(MSG)

 +5        QUIT 

TXT       ; text of error messages to add

 +1       ;;IB261^Primary insurance subscriber is missing INSURED'S SEX^IB261^1^1

 +2       ;;IB262^Secondary insurance subscriber is missing INSURED'S SEX^IB262^1^1

 +3       ;;IB263^Tertiary insurance subscriber is missing INSURED'S SEX^IB263^1^1