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 ---[H[J[2J[HIB20P361 1959 printed Dec 13, 2024@02:02:22 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
