IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
;;2.0;INTEGRATED BILLING;**28,103,371,576**; 21-MAR-94;Build 45
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;AITC/JRA - IB*2.0*576 Added ZIPCHK9 function.
;
AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file
; Input: IBCPOL = pointer to health insurance policy file
; IBYR = fileman internal date, Default = dt
; IBASK = 1 if want to ask okay to add new entry
;
; Output: IBCAB = pointer to Annual Benefits file if added, else null
;
N DIR,IBCAB
S IBCAB=""
I $G(IBCPOL)="" G ABQ
I $G(IBYR)="" S IBYR=DT
;S IBYR=$E(IBYR,1,3)_"0000"
;
; -- try to find entry for policy for year
S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0))
;
; -- if no match add new entry
I 'IBCAB D
.I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
.S IBCAB=$$ADDB(IBCPOL,IBYR)
.Q
ABQ Q IBCAB
;
ADDB(IBCPOL,IBYR) ; -- add entries to Annual Benefits file
; Input: IBCPOL = pointer to health insurance policy file
; IBYR = fileman internal date, Default = dt
;
; Output: IBCAB = pointer to Annual Benefits file if added, else null
;
N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
S IBCAB=""
I $G(IBCPOL)="" G ADDBQ
I $G(IBYR)="" S IBYR=DT
K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4
;
;S X=$E(IBYR,1,3)_"0000"
S X=IBYR D FILE^DICN I +Y<0 G ADDBQ
S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL
D ^DIE K DIC,DIE,DA,DR
ADDBQ Q IBCAB
;
CHIP(IBCDFND) ; -- convert node with no hip pointer to one with hip pointer
; Input: IBCDFND = zeroth node of insurance type multiple
; = ^dpt(dfn,.312,ibcdfn,0)
;
; Output: IBCPOL = pointer to policy file
;
N IBCNS,IBGRP,IBGRNA,IBGRNU
S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0
I IBGRNA'=""!(IBGRNU'="") S IBGRP=1
S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU)
CHIPQ Q IBCPOL
;
HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) ; -- find internal entry number in policy file
; Input: IBCNS = pointer to ins co file
; IBGRP = 1 if group policy, 0 if not
; IBGRNA = group name
; IBGRNU = group number
;
; Output: IBCPOL = pointer to policy file
;
N %DT
S IBCPOL=""
I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ
S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy
I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ
;
S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ"
I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0))
I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both
;
S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ"
S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0))
I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both
;
I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D
.I IBGRNA="",IBGRNU="" Q
.S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU=""
.S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";")
.D ^DIE K DA,DR,DIC,DIE
HIPQ Q IBCPOL
;
ADDH(IBCNS,IBGRP,IBGNA,IBGNU) ; -- add entries to health insurance policy file (355.3)
; Input: IBCNS = pointer to ins co file
; IBGRP = 1 if group policy, 0 if no
;
; Output: IBCPOL = pointer to policy file, if added else null
;
N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
S IBCPOL=""
I $G(IBCNS)="" G ADDHQ
K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3
;
S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ
S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP)
I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN
I $D(IBGNU) S DR=DR_";.04///^S X=IBGNU"
I $D(IBGNA) S DR=DR_";.03///^S X=IBGNA"
D ^DIE K DA,DR,DIE,DIC
I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1
ADDHQ Q IBCPOL
;
ODELP(DFN,INS) ; -- can an insurance policy be deleted
; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
; -- input dfn: ien of patient in file 2.
; ins: ien of ins. co in file 36
;
; -- output 1 if no deletion allowed
; 0 if deletion allowed
N I,X,Y S X=0
;
; -- do not delete if any uncancelled bills
S J=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q
ODELPQ Q X
;
STRIP(X,X1) ; -- strip characters from string
; input: x = string
; x1 = character to strip (default is ";"
N I,X2
S X2="" S:$G(X1)="" X1=";"
S X1=$E(X1)
F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1)
Q X2
;
;
DELP(DFN,INS,IBC) ; -- can an insurance policy be deleted
; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
; -- input dfn: ien of patient in file 2.
; ins: ien of ins. co in file 36
; ibc: ien of policy in file 2.312 to do a match
;
; -- output 1 if no deletion allowed
; 0 if deletion allowed
;
N ARR,J,ONEPOL,X
;
; - check input
I '$G(DFN)!'$G(INS) S X=1 G DELPQ
;
; - see if vet has more than one policy with carrier; set flag
; - also, if no policy is passed, assume the patient has one policy
I $G(IBC) D
.S J=0 F S J=$O(^DPT("AB",IBC,DFN,J)) Q:'J S ARR(J)=$G(^DPT(DFN,.312,J,0))
.S (J,ONEPOL)=0 S J=$O(ARR(J)) I J,'$O(ARR(J)) S ONEPOL=1
E S ONEPOL=1
;
;
; -- do not delete if any uncancelled bills
S (J,X)=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J D Q:X
.;
.N ARRP,POL,K,L,M,MP,S,Z
.S Z=$G(^DGCR(399,J,0)),M=$G(^("M")),MP=$G(^("MP")),S=$G(^("S"))
.;
.; - skip cancelled bills
.I $P(S,"^",17)'="" Q
.;
.; - set flag if the patient has just one policy with the company
.I ONEPOL S X=1 Q
.;
.; - if there are no policy pointers in the claim,
.I '$P(M,"^",12),'$P(M,"^",13),'$P(M,"^",14),'$P(MP,"^",2) D Q
..;
..; - find all policies effective on the event date
..S K=0 F S K=$O(ARR(K)) Q:'K S POL=ARR(K) D
...I $P(POL,"^",8) Q:$P(Z,"^",3)<$P(POL,"^",8)
...I $P(POL,"^",4) Q:$P(Z,"^",3)>$P(POL,"^",4)
...S ARRP(K)=""
..;
..; - if there are two such policies, trust user judgement and assume
..; - policy is not related to this claim.
..S L=$O(ARRP(0)) I L,$O(ARR(L)) Q
..;
..; - if there is just one policy, and it is the same as the one
..; - passed in, do not allow deletion.
..I L=IBC S X=1
.;
.; - if one of the claim policy pointers is the same as the policy
.; - passed in, do not allow deletion.
.I $P(MP,"^",2)=IBC S X=1 Q
.I $P(M,"^",12)=IBC!($P(M,"^",13)=IBC)!($P(M,"^",14)=IBC) S X=1
;
;
DELPQ Q X
;
DUPADDRL(DATA,IBCNS,FLD1,FLD2) ; Insurance address lines can not be duplicated
; DATA - Value being compared
; FLD1 - First field to check against
; FLD2 - Second field to check against (OPTIONAL)
;
; Returns 1 if this field is a duplicate of another field.
;
N Z1,Z2
Q:$G(DATA)="" 0 ; should not happen because this is invoked as an input transform
Q:'$G(IBCNS) 1 ; stop from editing through fileman
S DATA=$$UP^XLFSTR($G(DATA)),DATA=$$TRIM^XLFSTR(DATA)
S Z1=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD1),"I")
S Z1=$$UP^XLFSTR(Z1),Z1=$$TRIM^XLFSTR(Z1)
S Z2=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD2),"I")
S Z2=$$UP^XLFSTR(Z2),Z2=$$TRIM^XLFSTR(Z2)
I DATA=Z1 D CLEAN^DILF Q 1
I DATA=Z2 D CLEAN^DILF Q 1
D CLEAN^DILF
Q 0
;
ZIPCHK9(ZIP) ;AITC/JRA - IB*2.0*576 Check if ZIP is in proper 9-digit format
;Zip must be in the form '123456789' or '12345-6789' and the last 4 digits can't be
; '0000' or '9999'.
N ZIP4
I ZIP'?9N,(ZIP'?5N1"-"4N) Q 0
S ZIP4=$S(ZIP["-":$P(ZIP,"-",2),1:$E(ZIP,6,9)) I ZIP4="0000"!(ZIP4="9999") Q 0
Q ZIP
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSU 7656 printed Dec 13, 2024@02:17:56 Page 2
IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
+1 ;;2.0;INTEGRATED BILLING;**28,103,371,576**; 21-MAR-94;Build 45
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;AITC/JRA - IB*2.0*576 Added ZIPCHK9 function.
+5 ;
AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file
+1 ; Input: IBCPOL = pointer to health insurance policy file
+2 ; IBYR = fileman internal date, Default = dt
+3 ; IBASK = 1 if want to ask okay to add new entry
+4 ;
+5 ; Output: IBCAB = pointer to Annual Benefits file if added, else null
+6 ;
+7 NEW DIR,IBCAB
+8 SET IBCAB=""
+9 IF $GET(IBCPOL)=""
GOTO ABQ
+10 IF $GET(IBYR)=""
SET IBYR=DT
+11 ;S IBYR=$E(IBYR,1,3)_"0000"
+12 ;
+13 ; -- try to find entry for policy for year
+14 SET IBCAB=$ORDER(^IBA(355.4,"APY",IBCPOL,-IBYR,0))
+15 ;
+16 ; -- if no match add new entry
+17 IF 'IBCAB
Begin DoDot:1
+18 IF $GET(IBASK)
SET DIR(0)="Y"
SET DIR("A")="Are you adding a new Annual Benefits YEAR"
SET DIR("B")="YES"
DO ^DIR
IF $DATA(DIRUT)!(Y<1)
SET VALMQUIT=""
QUIT
+19 SET IBCAB=$$ADDB(IBCPOL,IBYR)
+20 QUIT
End DoDot:1
ABQ QUIT IBCAB
+1 ;
ADDB(IBCPOL,IBYR) ; -- add entries to Annual Benefits file
+1 ; Input: IBCPOL = pointer to health insurance policy file
+2 ; IBYR = fileman internal date, Default = dt
+3 ;
+4 ; Output: IBCAB = pointer to Annual Benefits file if added, else null
+5 ;
+6 NEW %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
+7 SET IBCAB=""
+8 IF $GET(IBCPOL)=""
GOTO ADDBQ
+9 IF $GET(IBYR)=""
SET IBYR=DT
+10 KILL DD,DO,DIC,DR
SET DIC="^IBA(355.4,"
SET DIC(0)="L"
SET DLAYGO=355.4
+11 ;
+12 ;S X=$E(IBYR,1,3)_"0000"
+13 SET X=IBYR
DO FILE^DICN
IF +Y<0
GOTO ADDBQ
+14 SET (IBCAB,DA)=+Y
SET DIE="^IBA(355.4,"
SET DR=".02////"_IBCPOL
+15 DO ^DIE
KILL DIC,DIE,DA,DR
ADDBQ QUIT IBCAB
+1 ;
CHIP(IBCDFND) ; -- convert node with no hip pointer to one with hip pointer
+1 ; Input: IBCDFND = zeroth node of insurance type multiple
+2 ; = ^dpt(dfn,.312,ibcdfn,0)
+3 ;
+4 ; Output: IBCPOL = pointer to policy file
+5 ;
+6 NEW IBCNS,IBGRP,IBGRNA,IBGRNU
+7 SET IBCNS=+IBCDFND
SET IBGRNA=$PIECE(IBCDFND,"^",15)
SET IBGRNU=$PIECE(IBCDFND,"^",3)
SET IBGRP=0
+8 IF IBGRNA'=""!(IBGRNU'="")
SET IBGRP=1
+9 SET IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU)
CHIPQ QUIT IBCPOL
+1 ;
HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) ; -- find internal entry number in policy file
+1 ; Input: IBCNS = pointer to ins co file
+2 ; IBGRP = 1 if group policy, 0 if not
+3 ; IBGRNA = group name
+4 ; IBGRNU = group number
+5 ;
+6 ; Output: IBCPOL = pointer to policy file
+7 ;
+8 NEW %DT
+9 SET IBCPOL=""
+10 IF $GET(^DIC(36,+$GET(IBCNS),0))=""
GOTO HIPQ
+11 ; if undefine, is not a group policy
SET IBGRP=+$GET(IBGRP)
+12 IF 'IBGRP
SET IBCPOL=$$ADDH(IBCNS,IBGRP)
GOTO HIPQ
+13 ;
+14 if $GET(IBGRNU)=""
SET IBGRNU="IB ZZZZZ"
+15 IF IBGRNU'="IB ZZZZZ"
SET IBCPOL=$ORDER(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0))
+16 ; match both
IF IBCPOL
IF $PIECE($GET(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA
GOTO HIPQ
+17 ;
+18 if $GET(IBGRNA)=""
SET IBGRNA="IB ZZZZZ"
+19 SET IBCPOL=$ORDER(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0))
+20 ; match both
IF IBCPOL
IF $PIECE($GET(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU
GOTO HIPQ
+21 ;
+22 IF 'IBCPOL
SET IBCPOL=$$ADDH(IBCNS,IBGRP)
Begin DoDot:1
+23 IF IBGRNA=""
IF IBGRNU=""
QUIT
+24 if IBGRNA="IB ZZZZZ"
SET IBGRNA=""
if IBGRNU="IB ZZZZZ"
SET IBGRNU=""
+25 SET DA=IBCPOL
SET DIE="^IBA(355.3,"
SET DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";")
+26 DO ^DIE
KILL DA,DR,DIC,DIE
End DoDot:1
HIPQ QUIT IBCPOL
+1 ;
ADDH(IBCNS,IBGRP,IBGNA,IBGNU) ; -- add entries to health insurance policy file (355.3)
+1 ; Input: IBCNS = pointer to ins co file
+2 ; IBGRP = 1 if group policy, 0 if no
+3 ;
+4 ; Output: IBCPOL = pointer to policy file, if added else null
+5 ;
+6 NEW %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
+7 SET IBCPOL=""
+8 IF $GET(IBCNS)=""
GOTO ADDHQ
+9 KILL DD,DO,DIC,DR
SET DIC="^IBA(355.3,"
SET DIC(0)="L"
SET DLAYGO=355.3
+10 ;
+11 SET X=IBCNS
DO FILE^DICN
IF +Y<0
GOTO ADDHQ
+12 SET (DA,IBCPOL)=+Y
SET DIE="^IBA(355.3,"
SET DR=".02////"_+$GET(IBGRP)
+13 IF IBGRP=0
IF $GET(DFN)
SET DR=DR_";.1////"_DFN
+14 IF $DATA(IBGNU)
SET DR=DR_";.04///^S X=IBGNU"
+15 IF $DATA(IBGNA)
SET DR=DR_";.03///^S X=IBGNA"
+16 DO ^DIE
KILL DA,DR,DIE,DIC
+17 IF $GET(IBCNTP)'=""
SET IBCNTP=IBCNTP+1
ADDHQ QUIT IBCPOL
+1 ;
ODELP(DFN,INS) ; -- can an insurance policy be deleted
+1 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
+2 ; -- input dfn: ien of patient in file 2.
+3 ; ins: ien of ins. co in file 36
+4 ;
+5 ; -- output 1 if no deletion allowed
+6 ; 0 if deletion allowed
+7 NEW I,X,Y
SET X=0
+8 ;
+9 ; -- do not delete if any uncancelled bills
+10 SET J=0
FOR
SET J=$ORDER(^DGCR(399,"AE",DFN,INS,J))
if 'J
QUIT
IF $PIECE(^DGCR(399,J,"S"),"^",17)=""
SET X=1
QUIT
ODELPQ QUIT X
+1 ;
STRIP(X,X1) ; -- strip characters from string
+1 ; input: x = string
+2 ; x1 = character to strip (default is ";"
+3 NEW I,X2
+4 SET X2=""
if $GET(X1)=""
SET X1=";"
+5 SET X1=$EXTRACT(X1)
+6 FOR I=1:1
SET X2=X2_$PIECE(X,X1,I)
if ($PIECE(X,X1,I+1,999)'[X1)
QUIT
+7 QUIT X2
+8 ;
+9 ;
DELP(DFN,INS,IBC) ; -- can an insurance policy be deleted
+1 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
+2 ; -- input dfn: ien of patient in file 2.
+3 ; ins: ien of ins. co in file 36
+4 ; ibc: ien of policy in file 2.312 to do a match
+5 ;
+6 ; -- output 1 if no deletion allowed
+7 ; 0 if deletion allowed
+8 ;
+9 NEW ARR,J,ONEPOL,X
+10 ;
+11 ; - check input
+12 IF '$GET(DFN)!'$GET(INS)
SET X=1
GOTO DELPQ
+13 ;
+14 ; - see if vet has more than one policy with carrier; set flag
+15 ; - also, if no policy is passed, assume the patient has one policy
+16 IF $GET(IBC)
Begin DoDot:1
+17 SET J=0
FOR
SET J=$ORDER(^DPT("AB",IBC,DFN,J))
if 'J
QUIT
SET ARR(J)=$GET(^DPT(DFN,.312,J,0))
+18 SET (J,ONEPOL)=0
SET J=$ORDER(ARR(J))
IF J
IF '$ORDER(ARR(J))
SET ONEPOL=1
End DoDot:1
+19 IF '$TEST
SET ONEPOL=1
+20 ;
+21 ;
+22 ; -- do not delete if any uncancelled bills
+23 SET (J,X)=0
FOR
SET J=$ORDER(^DGCR(399,"AE",DFN,INS,J))
if 'J
QUIT
Begin DoDot:1
+24 ;
+25 NEW ARRP,POL,K,L,M,MP,S,Z
+26 SET Z=$GET(^DGCR(399,J,0))
SET M=$GET(^("M"))
SET MP=$GET(^("MP"))
SET S=$GET(^("S"))
+27 ;
+28 ; - skip cancelled bills
+29 IF $PIECE(S,"^",17)'=""
QUIT
+30 ;
+31 ; - set flag if the patient has just one policy with the company
+32 IF ONEPOL
SET X=1
QUIT
+33 ;
+34 ; - if there are no policy pointers in the claim,
+35 IF '$PIECE(M,"^",12)
IF '$PIECE(M,"^",13)
IF '$PIECE(M,"^",14)
IF '$PIECE(MP,"^",2)
Begin DoDot:2
+36 ;
+37 ; - find all policies effective on the event date
+38 SET K=0
FOR
SET K=$ORDER(ARR(K))
if 'K
QUIT
SET POL=ARR(K)
Begin DoDot:3
+39 IF $PIECE(POL,"^",8)
if $PIECE(Z,"^",3)<$PIECE(POL,"^",8)
QUIT
+40 IF $PIECE(POL,"^",4)
if $PIECE(Z,"^",3)>$PIECE(POL,"^",4)
QUIT
+41 SET ARRP(K)=""
End DoDot:3
+42 ;
+43 ; - if there are two such policies, trust user judgement and assume
+44 ; - policy is not related to this claim.
+45 SET L=$ORDER(ARRP(0))
IF L
IF $ORDER(ARR(L))
QUIT
+46 ;
+47 ; - if there is just one policy, and it is the same as the one
+48 ; - passed in, do not allow deletion.
+49 IF L=IBC
SET X=1
End DoDot:2
QUIT
+50 ;
+51 ; - if one of the claim policy pointers is the same as the policy
+52 ; - passed in, do not allow deletion.
+53 IF $PIECE(MP,"^",2)=IBC
SET X=1
QUIT
+54 IF $PIECE(M,"^",12)=IBC!($PIECE(M,"^",13)=IBC)!($PIECE(M,"^",14)=IBC)
SET X=1
End DoDot:1
if X
QUIT
+55 ;
+56 ;
DELPQ QUIT X
+1 ;
DUPADDRL(DATA,IBCNS,FLD1,FLD2) ; Insurance address lines can not be duplicated
+1 ; DATA - Value being compared
+2 ; FLD1 - First field to check against
+3 ; FLD2 - Second field to check against (OPTIONAL)
+4 ;
+5 ; Returns 1 if this field is a duplicate of another field.
+6 ;
+7 NEW Z1,Z2
+8 ; should not happen because this is invoked as an input transform
if $GET(DATA)=""
QUIT 0
+9 ; stop from editing through fileman
if '$GET(IBCNS)
QUIT 1
+10 SET DATA=$$UP^XLFSTR($GET(DATA))
SET DATA=$$TRIM^XLFSTR(DATA)
+11 SET Z1=$$GET1^DIQ(36,+$GET(IBCNS),+$GET(FLD1),"I")
+12 SET Z1=$$UP^XLFSTR(Z1)
SET Z1=$$TRIM^XLFSTR(Z1)
+13 SET Z2=$$GET1^DIQ(36,+$GET(IBCNS),+$GET(FLD2),"I")
+14 SET Z2=$$UP^XLFSTR(Z2)
SET Z2=$$TRIM^XLFSTR(Z2)
+15 IF DATA=Z1
DO CLEAN^DILF
QUIT 1
+16 IF DATA=Z2
DO CLEAN^DILF
QUIT 1
+17 DO CLEAN^DILF
+18 QUIT 0
+19 ;
ZIPCHK9(ZIP) ;AITC/JRA - IB*2.0*576 Check if ZIP is in proper 9-digit format
+1 ;Zip must be in the form '123456789' or '12345-6789' and the last 4 digits can't be
+2 ; '0000' or '9999'.
+3 NEW ZIP4
+4 IF ZIP'?9N
IF (ZIP'?5N1"-"4N)
QUIT 0
+5 SET ZIP4=$SELECT(ZIP["-":$PIECE(ZIP,"-",2),1:$EXTRACT(ZIP,6,9))
IF ZIP4="0000"!(ZIP4="9999")
QUIT 0
+6 QUIT ZIP
+7 ;
