Index: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m
===================================================================
--- WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m	(revision 623)
@@ -1,155 +1,117 @@
-IBCNSU1	;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
-	;;2.0;INTEGRATED BILLING;**103,133,244,371**;21-MAR-94;Build 57
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-RCHK(X)	; -- Input transform for different revenue codes in file 36
-	;    Returns 1 if passes, 0 if not pass input transform
-	;
-	N I,Y,RC,NO S Y=0
-	I $G(X)="" G RCHKQ
-	F I=1:1 S RC=$P(X,",",I) Q:RC=""  I $S(RC?3N:0,RC?5N:0,1:1) S NO=1 Q
-	I '$G(NO) S Y=1
-RCHKQ	Q Y
-	;
-BU(DFN,IBCPOL,IBYR,IBCDFN,IBASK)	; -- Return entry in Benefits Used file
-	;     Input:  IBCDFN  = pointer to patient file policy (2.312)
-	;             DFN     = patient pointer        
-	;             IBCPOL  = pointer to health insurance policy file
-	;             IBYR    = fileman internal date, year will be calendar
-	;                       year of the internal date, Default = dt
-	;             IBASK   = 1 if want to ask okay to add new entry
-	;
-	;    Output:  IBCBU   = pointer to Benefits Used file if added,
-	;                       else null
-	;
-	N DIR,IBCBU
-	S IBCBU=""
-	I $G(IBCPOL)="" G BUQ
-	I $G(IBYR)="" S IBYR=DT
-	;
-	;if no match display message
-	I '$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) W !!,"You cannot add a new Benefits Used BENEFIT YEAR",!! G BUQ
-	;
-	; -- try to find entry for policy for year
-	S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
-	;
-	; -- if no match add new entry
-	I 'IBCBU D
-	.I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Benefits Used YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
-	.S IBCBU=$$ADDBU(DFN,IBCPOL,IBYR,IBCDFN)
-	.Q
-	;
-BUQ	Q IBCBU
-	;
-ADDBU(DFN,IBCPOL,IBYR,IBCDFN)	; -- add entries to Benefits Used file
-	;     Input:  DFN     = pointer to patient file
-	;             IBCDFN  = point to patient policy (2.312)
-	;             IBCPOL  = pointer to health insurance policy file
-	;             IBYR    = fileman internal date, year will be calendar
-	;                       year of the internal date, Default = dt
-	;
-	;    Output:  IBCBU   = pointer to Benefits Used file if added,
-	;                       else null
-	;
-	N %DT,IBN1,IBCBU,DIC,DIE,DR,DA,DLAYGO,DO,DD
-	S IBCBU=""
-	I $G(IBCDFN)="" G ADDBUQ
-	I $G(IBCPOL)="" G ADDBUQ
-	I $G(IBYR)="" S IBYR=DT
-	K DD,DO,DIC,DR S DIC="^IBA(355.5,",DIC(0)="L",DLAYGO=355.5
-	;
-	;S IBYR=$E(IBYR,1,3)_"0000"
-	S X=IBCPOL D FILE^DICN I +Y<0 G ADDBUQ
-	S (IBCBU,DA)=+Y,DIE="^IBA(355.5,",DR=".02////"_DFN_";.03////"_IBYR_";.17////"_IBCDFN_";1.01///NOW;1.02////"_DUZ
-	D ^DIE K DIC,DIE,DA,DR
-ADDBUQ	Q IBCBU
-	;
-VET()	; -- Input Transform for sub-file 2.312, Name of Insured (#17)
-	;    Quit 1 to stuff Patient Name
-	;    Quit 0 to not stuff and allow editing
-	;
-	N IBY,IB0 S IBY=0
-	G VETQ    ; IB*2*371 - Allow edits to the patient name in all cases
-	S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
-	I $P(IB0,"^",6)'="v" G VETQ
-	I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ
-	I '$D(X),$P(IB0,"^",17)="" S IBY=1
-VETQ	Q IBY
-	;
-	;
-SUBID	; -- Input Transform for sub-file #2.312, Subscriber ID (#1)
-	N NODE,L,R,CHAR,X1
-	S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """
-	S NODE=^DPT(DA(1),.312,DA,0)
-	;
-	; - if the policy is a Medicare policy, make sure the subscriber ID
-	;   is a valid HICN number
-	I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q
-	;
-	S R=$P(NODE,U,16)
-	S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"")
-	S R=$S(R="01":1,R="":1,1:0)
-	;
-	; - if subscriber ID is the SSN of patient, remove all extraneous
-	;   characters
-	S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
-	;
-	K:$L(X)>20!($L(X)<3) X
-	Q
-	;
-	;
-HICN(DFN)	; -- return Patient's Medicare HIC number
-	;    Return HICN of Medicare WNR Part A or Part B
-	;    Return -1 if none exits
-	;
-	N IBWNR,IBX,IBY,IB0
-	S IBWNR=$$GETWNR^IBCNSMM1,IBY=""
-	I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ
-	S IBX=0 F  S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"")  D
-	.S IB0=$G(^DPT(DFN,.312,IBX,0))
-	.I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q
-	.; 8/18/2003 - Added translation code to remove hyphens if they exist.
-	.I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","")
-	S:IBY="" IBY=-1
-HICNQ	Q IBY
-	;
-CHKQUAL(DFN,IEN,QUAL,PC1,PC2)	; check for duplicate qualifiers for patient
-	; and subscriber secondary ID's.  All parameters required.
-	;
-	;   DFN - internal patient#
-	;   IEN - ien of 2.312 subfile
-	;  QUAL - passed in response of the user (this is what is being 
-	;         checked to see if it is valid)
-	;   PC1 - this is the piece# for one of the other qualifiers
-	;   PC2 - this is the piece# for one of the other qualifiers
-	;
-	; Function returns 1 if the entered qualifier is OK.
-	; Function returns 0 if the entered qualifier is not OK.  It is either
-	;                    a duplicate or is otherwise invalid.
-	;
-	NEW OK,DATA,INS
-	S OK=1
-	I $G(QUAL)="" G CHKQUALX
-	S DATA=$G(^DPT(+$G(DFN),.312,+$G(IEN),5))
-	I $G(QUAL)=$P(DATA,U,+$G(PC1)) D CQ1 G CHKQUALX   ; duplicate
-	I $G(QUAL)=$P(DATA,U,+$G(PC2)) D CQ1 G CHKQUALX   ; duplicate
-	;
-	; prevent the SSN qualifier when Medicare is the payer
-	S INS=+$G(^DPT(+$G(DFN),.312,+$G(IEN),0))
-	I $G(QUAL)="SY",$$MCRWNR^IBEFUNC(INS) D CQ2 G CHKQUALX
-	;
-CHKQUALX	;
-	Q OK
-	;
-CQ1	; specific error message#1
-	S OK=0
-	D EN^DDIOL("You cannot use the same qualifier more than once.",,"!!")
-	D EN^DDIOL("",,"!!?5")
-	Q
-	;
-CQ2	; specific error message#2
-	S OK=0
-	D EN^DDIOL("You cannot use qualifier 'SY' for Medicare.",,"!!")
-	D EN^DDIOL("",,"!!?5")
-	Q
-	;
+IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
+ ;;2.0;INTEGRATED BILLING;**103,133,244**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+RCHK(X) ; -- Input transform for different revenue codes in file 36
+ ;    Returns 1 if passes, 0 if not pass input transform
+ ;
+ N I,Y,RC,NO S Y=0
+ I $G(X)="" G RCHKQ
+ F I=1:1 S RC=$P(X,",",I) Q:RC=""  I $S(RC?3N:0,RC?5N:0,1:1) S NO=1 Q
+ I '$G(NO) S Y=1
+RCHKQ Q Y
+ ;
+BU(DFN,IBCPOL,IBYR,IBCDFN,IBASK) ; -- Return entry in Benefits Used file
+ ;     Input:  IBCDFN  = pointer to patient file policy (2.312)
+ ;             DFN     = patient pointer        
+ ;             IBCPOL  = pointer to health insurance policy file
+ ;             IBYR    = fileman internal date, year will be calendar
+ ;                       year of the internal date, Default = dt
+ ;             IBASK   = 1 if want to ask okay to add new entry
+ ;
+ ;    Output:  IBCBU   = pointer to Benefits Used file if added,
+ ;                       else null
+ ;
+ N DIR,IBCBU
+ S IBCBU=""
+ I $G(IBCPOL)="" G BUQ
+ I $G(IBYR)="" S IBYR=DT
+ ;
+ ;if no match display message
+ I '$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) W !!,"You cannot add a new Benefits Used BENEFIT YEAR",!! G BUQ
+ ;
+ ; -- try to find entry for policy for year
+ S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
+ ;
+ ; -- if no match add new entry
+ I 'IBCBU D
+ .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Benefits Used YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
+ .S IBCBU=$$ADDBU(DFN,IBCPOL,IBYR,IBCDFN)
+ .Q
+ ;
+BUQ Q IBCBU
+ ;
+ADDBU(DFN,IBCPOL,IBYR,IBCDFN) ; -- add entries to Benefits Used file
+ ;     Input:  DFN     = pointer to patient file
+ ;             IBCDFN  = point to patient policy (2.312)
+ ;             IBCPOL  = pointer to health insurance policy file
+ ;             IBYR    = fileman internal date, year will be calendar
+ ;                       year of the internal date, Default = dt
+ ;
+ ;    Output:  IBCBU   = pointer to Benefits Used file if added,
+ ;                       else null
+ ;
+ N %DT,IBN1,IBCBU,DIC,DIE,DR,DA,DLAYGO,DO,DD
+ S IBCBU=""
+ I $G(IBCDFN)="" G ADDBUQ
+ I $G(IBCPOL)="" G ADDBUQ
+ I $G(IBYR)="" S IBYR=DT
+ K DD,DO,DIC,DR S DIC="^IBA(355.5,",DIC(0)="L",DLAYGO=355.5
+ ;
+ ;S IBYR=$E(IBYR,1,3)_"0000"
+ S X=IBCPOL D FILE^DICN I +Y<0 G ADDBUQ
+ S (IBCBU,DA)=+Y,DIE="^IBA(355.5,",DR=".02////"_DFN_";.03////"_IBYR_";.17////"_IBCDFN_";1.01///NOW;1.02////"_DUZ
+ D ^DIE K DIC,DIE,DA,DR
+ADDBUQ Q IBCBU
+ ;
+VET() ; -- Input Transform for sub-file 2.312, Name of Insured (#17)
+ ;    Quit 1 to stuff Patient Name
+ ;    Quit 0 to not stuff and allow editing
+ ;
+ N IBY,IB0 S IBY=0
+ S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
+ I $P(IB0,"^",6)'="v" G VETQ
+ I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ
+ I '$D(X),$P(IB0,"^",17)="" S IBY=1
+VETQ Q IBY
+ ;
+ ;
+SUBID ; -- Input Transform for sub-file #2.312, Subscriber ID (#1)
+ N NODE,L,R,CHAR,X1
+ S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """
+ S NODE=^DPT(DA(1),.312,DA,0)
+ ;
+ ; - if the policy is a Medicare policy, make sure the subscriber ID
+ ;   is a valid HICN number
+ I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q
+ ;
+ S R=$P(NODE,U,16)
+ S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"")
+ S R=$S(R="01":1,R="":1,1:0)
+ ;
+ ; - if subscriber ID is the SSN of patient, remove all extraneous
+ ;   characters
+ S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
+ ;
+ ; - if "SS" is entered, and the policy belongs to the patient,
+ ;   convert that string to the patient's SSN
+ I R=1,X="SS" W "  ",L S X=L
+ ;
+ K:$L(X)>20!($L(X)<3) X
+ Q
+ ;
+ ;
+HICN(DFN) ; -- return Patient's Medicare HIC number
+ ;    Return HICN of Medicare WNR Part A or Part B
+ ;    Return -1 if none exits
+ ;
+ N IBWNR,IBX,IBY,IB0
+ S IBWNR=$$GETWNR^IBCNSMM1,IBY=""
+ I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ
+ S IBX=0 F  S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"")  D
+ .S IB0=$G(^DPT(DFN,.312,IBX,0))
+ .I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q
+ .; 8/18/2003 - Added translation code to remove hyphens if they exist.
+ .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","")
+ S:IBY="" IBY=-1
+HICNQ Q IBY
