IBCVC ;ALB/WCJ - VALUE CODE FUNCTIONALITY ;25-JUN-07
;;2.0;INTEGRATED BILLING;**371,400,432,718,732,742**;21-MAR-94;Build 36
;;Per VA Directive 6402, this routine should not be modified.
G AWAY
AWAY Q
;
ALLOWVC(IBIFN,Y) ; see if the value code is obsolete.
; returns 0 = Not Allowed/Obsolete
; returns 1 = Allowed
;
N OBSDT,SCF
S OBSDT=$$GET1^DIQ(399.1,Y,.26,"I")
D CLEAN^DILF
Q:'+OBSDT 1 ; If there is no obsolete date, were cool
;
S SCF=$$GET1^DIQ(399,IBIFN,151,"I") ; get the statement covers from date to compare with
D CLEAN^DILF
I 'SCF Q 0 ; if there is none, not sure where to go with this. It's required so I say fail.
;
I SCF>OBSDT Q 0
;
Q 1
;
HELP ;
Q:'$G(DA)
Q:'$G(DA(1))
Q:'$D(^DGCR(399,DA(1),"CV",DA,0))
N VCPTR
S VCPTR=$P($G(^DGCR(399,DA(1),"CV",DA,0)),U)
Q:VCPTR=""
Q:'$D(^DGCR(399.1,VCPTR,1))
N LOOP
S LOOP=0 F S LOOP=$O(^DGCR(399.1,VCPTR,1,LOOP)) Q:'+LOOP D
.; W !,$G(^(LOOP,0)) ;IB742;WCJ
. D EN^DDIOL($G(^(LOOP,0)),"","!") ;IB742;WCJ
Q
;
FORMCHK(X,DA) ; Check to make sure that the VALUE is in the correct format base on the VALUE CODE.
; This tag is the input transform for the VALUE field (Sub-File 399.047, field .02).
;
; X = data being verified
; DA = subfile entry
; DA(1) = IEN to 399
;
; returns
; 0 = invalid format
; 1 = valid format
;
Q:$L(X)<1 0 ; WCJ;IB*2.0*742;v4
Q:$L(X)>10 0 ; WCJ;IB*2.0*742;v4
Q:'$G(DA) 0
Q:'$G(DA(1)) 0
Q:'$D(^DGCR(399,DA(1),"CV",DA,0)) 0
;
N VCPTR
S VCPTR=$P($G(^DGCR(399,DA(1),"CV",DA,0)),U)
Q:VCPTR="" 0
;
Q $$CHK(VCPTR,X)
;
CHK(VCPTR,X) ; This tag is called from the input transform above and also from the IB edit check routines (IBCBB*)
; This function is passed in:
; VCPTR - pointer into file #399.1
; X - the VALUE being checked
; Returns:
; 0 or false - Invalid format or can't figure it out.
; 1 or true - valid format (or in the case of 24, defined at the state level)
;
N CODE,OK
S CODE=$$GET1^DIQ(399.1,VCPTR_",",.02,"I")
D CLEAN^DILF
Q:CODE="" 0
;
N AMTFLG
;
; Check to see if it goes out as a monetary amount.
S AMTFLG=$$GET1^DIQ(399.1,VCPTR_",",.19,"I")
D CLEAN^DILF
I AMTFLG Q X?1(1.7N,.7N1"."1.2N)
;
; Medicaid Rate Code (This is defined at the state level)
;TPF;IB*2.0*718;EBILL-1570;11/22/2021
I CODE=24 Q X?1.9AN&'(X?2"0"."0")
;Q:CODE=24 1
;
; Accident Hour
I CODE=45 Q ".00.01.02.03.04.05.06.07.08.09.10.11.12.13.14.15.16.17.18.19.20.21.22.23.99."[("."_X_".")
;
; Whole Numbers
;TPF;IB*2.0*718;EBILL-1570;11/22/2021 ADD NEW VC WHOLE NUMBERS (NUMERIC STRING)
I ".G8.62.63.32.37.38.39.46.50.51.52.53.56.57.58.59.67.68.69.80.81.82.83.84."[("."_CODE_".") Q X?1.7N&'(X?2"0"."0")
I ".D4."[("."_CODE_".") Q X?1.9N&'(X?2"0"."0")
;I ".37.38.39.46.50.51.52.53.56.57.58.59.67.68.80.81.82."[("."_CODE_".") Q X?1.7N
;
; Zip
I CODE="A0" Q X?5N&'(X?5"0")
;
;I ".48.49."[("."_CODE_".") S OK=1 D Q OK
;I ".54.48.49.A8.A9.D5."[("."_CODE_".") S OK=1 D Q OK ;TPF;IB*2.0*718;EBILL-1570;11/22/2021 ADD NEW VC DECIMAL NUMBERS (DECIMALS)
;. I $P(X,".")'?.2N S OK=0 Q
;. I $P(X,".",2,999)'?.1N S OK=0 Q
;. I $E(X,$L(X))="." S OK=0 Q
;ISSUE P718 DEAL WITH DECIMALS
S OK=0
I ".48.49."[("."_CODE_".") D Q OK ;HEMOGLOBIN AND HEMATOCRIT NN.NN
.S OK=(X?1.2N.1".".2N)&(X'?3.N)&($E(X,$L(X))'=".")
;
I ".A8.A9."[("."_CODE_".") D Q OK ;HEIGHT AND WEIGHT NNN.NN weight in Kg, Height in cm
.S OK=(X?1.3N.1".".2N)&(X'?4.N)&($E(X,$L(X))'=".")
;
I ".D5."[("."_CODE_".") D Q OK ;LAST KT NN.NN
.S OK=(X?1.2N1".".2N)&($E(X,$L(X))'=".")
;
I ".54."[("."_CODE_".") D Q OK ;NEWBORN WEIGHT NNNN.NN
.S OK=(X?1.4N.1".".2N)&(X'?5.N)&($E(X,$L(X))'=".")
;END DECIMALS
;
; Alpha Numeric, no punctuation
I ".60.61."[("."_CODE_".") Q X?1.7AN&'(X?2"0"."0")
Q 1
;
;TPF;IB*2.0*718;EBILL-1570;11/22/2021
PATCH718CHK(IEN) ;EP - CALLED FROM KIDS BUILD DATA SCREEN FOR FILE #399.1
I (U_58_U_79_U_80_U_642_U_643_U_639_U_678_U_689_U)[(U_IEN_U) Q 1
I $$NUMRANGE(IEN,60,62) Q 1
I $$NUMRANGE(IEN,45,47) Q 1
I $$NUMRANGE(IEN,74,76) Q 1
I $$NUMRANGE(IEN,82,84) Q 1
I $$NUMRANGE(IEN,86,91) Q 1
I $$NUMRANGE(IEN,94,99) Q 1
I $$NUMRANGE(IEN,102,104) Q 1
I $$NUMRANGE(IEN,265,268) Q 1
I $$NUMRANGE(IEN,587,590) Q 1
I $$NUMRANGE(IEN,634,638) Q 1
Q 0
;
;TPF;IB*2.0*718;EBILL-1570;11/22/2021
NUMRANGE(X,LOW,HIGH) ;EP - NUMBER RANGE CHECK
;RETURNS 1 IF X LIES WITHIN NUMBER RANGE
I (X=LOW!(X>LOW)),(X<HIGH!(X=HIGH)) Q 1
Q 0
;
;
;#.02 CODE #399.1 MCCR UTILITY ^ #.02 VALUE #399.047 VALUE CODE #399 BILL/CLAIMS ^ #.19 VALUE CODE AMOUNT #399.1 MCCR UTILITY ^ VALUE CODE IEN #399.1
;IBXSAVE("VALUE",1)="48^15^0^92"
;IBXSAVE("VALUE",2)="49^45.2^0^93"
;IBXSAVE("VALUE",3)="A9^32.9^^592"
;IBXSAVE("VALUE",4)="A8^60^^591"
;IBXSAVE("VALUE",5)="A3^22691.94^1"
;
;USE THIS IN PLACE OF CALL TO $$DOLLAR IN FILE #FORMAT CODE
VALCODEFMT(IBSAVE,IBDATA) ;EP - TAKE VALUE CODE ARRAY AND FORMAT EACH ACCORDINGTO DATA TYPE
N DOLLARAMT,VALCODEIEN,VALCODENAME,VALUE,DATATYPE ;WCJ;IB718;SQA
N TESTING
S TESTING=0 ;SET TO ONE IF TESTING TO SHOW DISPLAY HELPERS
Q:'$O(IBSAVE("VALUE",""))
W:$G(TESTING) !?25,"VC1-VC24 AMT FIELD"
W:$G(TESTING) !?25,"|123456789|",?40,"VALUE CODE",?55,"VALUE CODE NAME"
W:$G(TESTING) !?25,"-----------"
N IEN
S IEN=0
F S IEN=$O(IBSAVE("VALUE",IEN)) Q:'IEN D
.S VALUECODE=$P(IBSAVE("VALUE",IEN),U)
.S VALUE=$P(IBSAVE("VALUE",IEN),U,2) ;SUBFILE #399.047 FIELD #.02 OF FILE #399
.S DOLLARAMT=$P(IBSAVE("VALUE",IEN),U,3) ;FILE #399.1 MCCR UTILITY FIELD #.19 VALUE CODE AMOUNT
.S VALCODEIEN=$P(IBSAVE("VALUE",IEN),U,4)
.I 'VALCODEIEN S VALCODEIEN=$O(^DGCR(399.1,"C",VALUECODE,0))
.S VALCODENAME=""
.S:VALCODEIEN VALCODENAME=$P($G(^DGCR(399.1,VALCODEIEN,0)),U)
.;
.I DOLLARAMT S IBDATA(IEN)=$$FMTDOLLAR(VALUE) Q
.;
.;IF ITS NOT EXPLICITLY DECLARED A DOLLAR AMOUNT BY THE SETTING OF FIELD #.19 THE WE NEED TO DETERMINE
.;THE DATA TYPE AND LOOK AT THE ALLOWED VALUE FORMATS BASED ON THE HISTORICAL CODE IN CHK^.
.;
.S DATATYPE=$$DATATYPE(VALUECODE,VALUE,0)
.I DATATYPE="FMTNUMERIC" S IBDATA(IEN)=$$FMTNUMERIC(VALUE) Q
.I DATATYPE="FMTALPHANUM" S IBDATA(IEN)=$$FMTALPHANUM(VALUE) Q
.I DATATYPE="FMTDECIMAL" S IBDATA(IEN)=$$FMTDECIMAL(VALUE) Q
.E S IBDATA(IEN)=$$FMTSPECIAL(VALUE,VALUECODE) Q
W:$G(TESTING) !?25,"-----------"
W:$G(TESTING) !!
Q
;
;LENGTH = SIZE OF FORMAT FIELD
;JUST ="L" = LEFT JUSTIFIED
;JUST = "R" = RIGHT JUSTIFIED
;DECPT = 0 = DECIMAL PT IMPLIED
;DECPT = 1 = DECIMAL PT ADDED
;FILLCHAR = CHARACTER TO USE AS A FILLER
;
;W $$FORMAT^IBCVC("23.",8,"L",1," ",2)
;THIS IS NOT FOR ANY PRINTED FORM
FORMAT(DATA,LENGTH,JUST,DECPT,FILLCHAR,PRECISION,DATATYPE) ;EP - FORMAT PER SPECS
;
N FILL ;WCJ;IB718;SQA
N FILLER
S JUST=$$UP^XLFSTR($G(JUST))
S FILL='$G(FILLCHAR)=""
S DATA=$$ABS^XLFMTH(DATA)
S LENGTH=$G(LENGTH)
S DECPT=$G(DECPT)=1
;
I PRECISION S DATA=$J(VALUE,LENGTH,PRECISION) S:'DECPT DATA=$TR(DATA,".")
;
I FILLCHAR="" S DATA=$$TRIM^XLFSTR(DATA,"LR") Q DATA
;
I JUST="R" S DATA=$$RJ^XLFSTR(DATA,LENGTH,FILLCHAR)
E S DATA=$$LJ^XLFSTR(DATA,LENGTH,FILLCHAR)
Q DATA
;
FMTDOLLAR(VALUE) ;EP - FORMAT DOLLAR AMOUNTS
S VALUE=$$FORMAT(VALUE,9,"R",1,"",2)
W:$G(TESTING) !,"DATATYPE DOLLAR:",?25,"|",VALUE_"|"
W:$G(TESTING) ?45,VALUECODE,?55,$E(VALCODENAME,1,25)
Q VALUE
;
FMTNUMERIC(VALUE,DATATYPE) ;EP - FORMAT NUMERIC STRING
S VALUE=$$FORMAT^IBCVC(VALUE,7,"R",0,"",0)
W:$G(TESTING) !,"DATATYPE NUMERIC:",?25,"|",VALUE_"|"
W:$G(TESTING) ?45,VALUECODE,?55,$E(VALCODENAME,1,25)
Q VALUE
;
FMTALPHANUM(VALUE) ;EP - FORMAT ALPHANUMERICS
S VALUE=$$FORMAT^IBCVC(VALUE,7,"R",0,"",0)
W:$G(TESTING) !,"DATATYPE ALPHANUM:",?25,"|",VALUE_"|"
W:$G(TESTING) ?45,VALUECODE,?55,$E(VALCODENAME,1,25)
Q VALUE
;
FMTDECIMAL(VALUE) ;EP - FORMAT DECIMALS
;S VALUE=$$FORMAT^IBCVC(VALUE,$L(VALUE),"R",1,"",1,"FMTDECIMAL")
S VALUE=$$FORMAT^IBCVC(VALUE,$L(VALUE),"R",1,"",2,"FMTDECIMAL") ;TPF;IB*732
W:$G(TESTING) !,"DATATYPE DECIMAL:",?25,"|",VALUE_"|"
W:$G(TESTING) ?45,VALUECODE,?55,$E(VALCODENAME,1,25)
Q VALUE
;
;SPECIAL CASES
FMTSPECIAL(VALUE,VALUECODE) ;EP - SPECIAL CASE FORMAT
Q:$G(VALUECODE)="" VALUE
I VALUECODE="45" S VALUE=$$FORMAT(VALUE,7,"R",0,"",0,"FMTNUMERIC")
I VALUECODE="A0" S VALUE=$$FORMAT(VALUE,7,"R",1,"",0,"FMTNUMERIC")
I VALUECODE=24 S VALUE=$$FORMAT(VALUE,8,"R",1,"",0,"FMTALPHANUM")
W:$G(TESTING) !,"DATATYPE SPECIAL:",?25,"|"_VALUE_"|"
W:$G(TESTING) ?45,VALUECODE,?55,$E(VALCODENAME,1,25)
Q VALUE
;
;VALUE CODE DATATYPE DEFINITIONS
DATATYPE(CODE,VALUE,INPUTCHK) ;EP - WHAT TYPE OF DATA DOES IB IDENTIFIY THIS VALUE CODE TO BE
I $$NUMERIC(VALUECODE,VALUE,INPUTCHK) Q "FMTNUMERIC"
I $$DECIMALS(VALUECODE,VALUE,INPUTCHK) Q "FMTDECIMAL"
I $$ALPHANUM(VALUECODE,VALUE,INPUTCHK) Q "FMTALPHANUM"
I $$ZIPCODE(VALUECODE,VALUE,INPUTCHK) Q "FMTALPHANUM"
Q "SPECIAL"
;
NUMERIC(CODE,VALUE,INPUTCHK) ;EP - IS VALUE CODE WHOLE NUMBER AS DEFINED HISTORICALLY IN CHK^IBCVC
I (U_"G8"_U_"D4"_U_62_U_63_U_32_U_37_U_38_U_39_U_46_U_50_U_51_U_52_U_53_U_56_U_57_U_58_U_59_U_67_U_68_U_69_U_80_U_81_U_82_U_83_U_84_U)[(U_CODE_U)
Q:'$G(INPUTCHK) $T
Q VALUE?1.7N&'(X?2"0"."0")
;
ALPHANUM(CODE,VALUE,INPUTCHK) ;EP - IS VALUE CODE AN ALPHANUMERIC?
I (U_60_U_61_U)[(U_CODE_U)
Q:'$G(INPUTCHK) $T
Q VALUE?1.7AN&'(X?2"0"."0")
;
DECIMALS(CODE,VALUE,INPUTCHK) ;EP - IS VALUE CODE A "DECIMAL" AS DEFINED HISTORICALLY IN CHK^IBCVC
I (U_54_U_48_U_49_U_"A8"_U_"A9"_U_"D5"_U)[(U_CODE_U)
Q:'$G(INPUTCHK) $T
;
S OK=1 D Q OK
. I $P(X,".")'?.2N S OK=0 Q
. I $P(X,".",2,999)'?.1N S OK=0 Q
. I $E(X,$L(X))="." S OK=0 Q
Q 0
;
ZIPCODE(CODE,VALUE,INPUTCHK) ;EP - RETURN IF VALID ZIP IN FILE #5.11 ZIP CODE
I (U_"A0"_U)[(U_CODE_U)
Q:'$G(INPUTCHK) $T
Q X?5N
;I KNOW THIS IS OUT OF SCOPE BUT....
;PER BILL DO NOT INCLUDE
;DATE SHOULD BE DATE OF SERVICE NOT DATE BILL IS ENTERED?
;D ZIPCODE^DSICXIP(.RETURN,ZIPCODE,DT,1) ;DOES THIS NEED A ICR#
;RETURN="-1^Postal Code cannot be found"
;RETURN="87015^EDGEWOOD^NEW MEXICO^SANTA FE^35049^NM^35^2844"
Q $G(RETURN)>0
;
REMOVE(DA) ; Remove the VALUE field since it's in the wrong format.
; This is called from a NEW STYLE X-REF "AC" in file 399.047 field .01
N IENS,FDA
Q:'$G(DA)!'$G(DA(1))
S IENS=DA_","_DA(1)_","
S FDA(399.047,IENS,.02)="@"
D FILE^DIE(,"FDA")
D CLEAN^DILF
Q
;
COND(DA,OLDVC,NEWVC) ; Check if the VALUE is in a valid format for the new VALUE CODE.
; This is called from a NEW STYLE X-REF "AC" in file 399.047 field .01
; This function will return:
; 1 - Means that this VALUE should be deleted (It's in the wrong format)
; 0 - Means that this VALUE should NOT be deleted
Q:'$G(OLDVC) 0
Q:'$G(DA)!'$G(DA(1)) 0
N OLDVALUE
S OLDVALUE=$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,2)
Q:OLDVALUE="" 0
Q '$$CHK(NEWVC,OLDVALUE)
;
;IB*2.0*432 - TAZ - VC1 added
VC1(IBXIEN,IBFL) ;Code for the VC1 record of the IB 837 Transmission
;INPUT:
;IBXIEN - IEN of bill/claim file
;IBFL - output array passed by reference
;
;OUTPUT:
;IBFL - array contains the list of value codes to be included in the transmission
;
N IBI,IBX,Z,Z0,INST
S INST=$$FT^IBCEF(IBXIEN)=3
S (IBI,IBX)=0 F S IBX=$O(^DGCR(399,IBXIEN,"CV",IBX)) Q:'IBX D
. S Z=$G(^(IBX,0)),Z0=$G(^DGCR(399.1,+Z,0))
. I Z0="" Q
. I ",A3,B3,C3,"[(","_$P(Z0,U,2)_","),INST Q
. S IBI=IBI+1,IBFL(39,IBI)=$P(Z0,U,2)_U_$P(Z,U,2)_U_$P(Z0,U,12)_U_+Z
I INST D
. S CODE=$P("A3^B3^C3",U,$$COBN^IBCEF(IBXIEN))
. S Z=$G(^DGCR(399,IBXIEN,"U1")),Z0=Z-$P(Z,U,2)
. S IBI=IBI+1,IBFL(39,IBI)=CODE_U_Z0_U_1
Q
;
;TPF;IB*2.0*718;EBILL-1570;11/03/2021
;D VCSCREEN^IBCVC
VCSCREEN(X) ;EP - FIELD #2 VALUE CODE AMOUNT SCREEN, FILE #399.1 MCCR UTILITY INPUT TRANSFORM
;THE PURPOSE OF THIS INPUT TRANSFORM IS TO ALLOW THE USER TO EASILY PICK STANDARD VALUE AMOUNT screens
I $P(@DILK@(0),U,11)'=1 D Q ;CHECK FOR VALUE CODE TYPE ENTRIES
.K X
.D BMES^XPDUTL(" ")
.D MES^XPDUTL("ONLY 'VALUE CODE' ENTRIES CAN BE GIVEN A 'VALUE CODE AMOUNT SCREEN'")
;
I $G(DUZ(0))'="@" W !!,"PROGRAMMER ONLY EDITABLE FIELD!!!" H 1 Q
;
N MCODE
S MCODE=X
D ^DIM ;CHECK THE INCOMING X FOR VALID MUMPS CODE
I $D(X) D Q:$G(Y)
.W !!,"This is valid MUMPS code."
.W !!,X
.W !
.N DIR,X
.S DIR(0)="Y"
.S DIR("B")="Y"
.S DIR("A")="Is this is the screen for "_$P($G(^DGCR(399.1,91,0)),U)
.D ^DIR
E D
.W !!,"The following code is not valid MUMPS code"
.W !!,$G(MCODE)
.W !!,"Try a standard VALUE CODE AMOUNT screen or enter valid MUMPS code."
;
N DOLLAR S DOLLAR=$P(@DILK@(0),U,12)=1 ;IS THIS A DOLLAR AMOUNT?
;
N DIR,DIE,DIC,DA,DR,DIK,DTOUT,DUOUT,DIROUT,Y
N ERRORCODE,MCODE
S DIR(0)="SO^"
S DIR("B")="=" ;DEFAULT CHOICE - LIKELY THE MOST OFTEN USED EDIT CHECK FOR ALL NEW IB VALUE CODES
D STANCHOICE(.DIR,.MCODE) ;COLLECT STANDARD CHOICES
;
I DUZ(0)="@" S DIR(0)=DIR(0)_"M:ENTER MY OWN MUMPS CODE"
S DIR("A")="CHOOSE A STANDARD VALUE AMOUNT EDIT CHECK"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(Y="") K X Q ; Y=">"
;
I Y'="M" D Q
.D ASKFORERROR(.ERRORCODE,Y) ;ASK USER FOR #350.8 'IB ERROR' ASSOCIATED WITH THIS VALUE CODE AMOUNT EDIT CHECK
.I $G(ERRORCODE)="" K X Q
.S X=$$ADDWRAPPER($G(MCODE(Y)),ERRORCODE) ; Y(0)="IF VCVALUE>0"
;
D MUMPSCODE(.X)
Q
;
MUMPSCODE(MUMPSCODE) ;EP - GET NON-STANDARD MUMPS CODE FOR CODE VALUE AMOUNT EDIT CHECK
D BMES^XPDUTL(" ")
D MES^XPDUTL("REMEMBER TO UTILIZE THE STANDARD VARIABLE 'IBVCVALUE'")
D MES^XPDUTL("REMEMBER TO SET THE VARIABLE 'IBVCERR' TO 1 ON AN ERROR CONDITION.")
D MES^XPDUTL("REMEMBER TO CALL $$IBER^IBCBB3 TO SET THE ERROR LIST.")
D MES^XPDUTL("REMEMBER TO REFERNCE YOUR NEW IB ERROR CODE PROPERLY TOO.")
D MES^XPDUTL("EXAMPLE:")
D BMES^XPDUTL("Q:$G(IBVCVALUE)="""" I IBVCVALUE<5,$G(IBER)'[(""9999;"") S IBQUIT=$$IBER^IBCBB3(.IBER,9999),IBVCERR=1")
D BMES^XPDUTL(" ")
;
N DIR,DIE,DIC,DA,DR,DIK,DTOUT,DUOUT,DIROUT,Y
S DIR(0)="FOU^0:245^Q:X="""" D:$D(X) ^DIM Q:'$D(X) K:X'[(""IBVCVALUE"")&(X'[(""IBVCERR"")) X"
S DIR("A")="Enter MUMPS Edit Check Code"
S DIR("?")="Code cannot be >245 characters, must be legal MUMPS code and reference IBVCVALUE and IBVCERR"
D ^DIR
I X="@" K X
Q
;
ASKFORERROR(ERROR,STANCHOICE) ;EP - ASK FOR ERROR
N DIR,DIE,DIC,DA,DR,DIK,DTOUT,DUOUT,DIROUT,X,Y
REDO ;
D BMES^XPDUTL(" ")
D MES^XPDUTL("You must associate an IB ERROR error code to this error condition.")
D MES^XPDUTL("For now, If you need a new error code you must create one separtely.")
D BMES^XPDUTL(" ")
S DIC="^IBE(350.8,"
S DIC(0)="AEMQZ"
D ^DIC
Q:X=U!(X="")
G:Y<0 REDO
S ERROR=$P($P($P(Y,U,2),"IB",2)," ")
Q
;
ADDWRAPPER(CODESTR,ERRORCODE) ;EP - ADD BASIC CODE TOCHECKFOR VALUE AND ADD STANDARD IBER CALL
N PREFIX,SUFFIX
S PREFIX="" ;"Q:$G(IBVCVALUE)="""" " NO VALUE CHECK IS HARDCODED IN IBCBB5
S SUFFIX=",$G(IBER)'[("""_ERRORCODE_";"") S IBQUIT=$$IBER^IBCBB3(.IBER,"_ERRORCODE_"),IBVCERR=1"
S CODESTR=PREFIX_CODESTR_SUFFIX
Q CODESTR
;
STANCHOICE(DIR,MCODE) ;EP-PULL STANDARD (OR EASY USER) CHOICES
N CHOICE,SETCODE ;WCJ;IB718;SQA
N OFFSET
F OFFSET=1:1 S CHOICE=$P($T(STANCHOICES+OFFSET),";;",2) Q:CHOICE="STOP" D
.S MCODE=$P(CHOICE,"|",2)
.S CHOICE=$P(CHOICE,"|")
.S SETCODE=$P(CHOICE,":")
.S MCODE(SETCODE)=MCODE
.S DIR(0)=$G(DIR(0))_CHOICE_";"
Q
;
;ADD STANDARD EASY CHOICES HERE SO YOU DON'T HAVE TO ADD THEM TO THE DIR(0) STRING MANUALLY
;SHORCUT:USER READABLE PSEUDO CODE | MUMPS CODE
STANCHOICES ;;
;;=0:ONLY ZERO ALLOWED|I $G(IBVCVALUE)'=0
;;>0:IF VALUE CODE AMOUNT GREATER THAN ZERO THEN ERROR|I +$G(IBVCVALUE)>0
;;<0:IF VALUE CODE AMOUNT LESS THAN ZERO THEN ERROR|I +$G(IBVCVALUE)<0
;;=:IF VALUE CODE AMOUNT EQUALS ZERO THEN ERROR|I +$G(IBVCVALUE)=0|IB916
;;<sp>:IF VALUE CODE AMOUNT EQUALS A SPACE THEN ERROR|I $G(IBVCVALUE)=""
;;'<sp>:IF VALUE CODE AMOUNT EQUALS NOT EQUAL A SPACE THEN ERROR|I $G(IBVCVALUE)'=""
;;STOP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCVC 16109 printed Oct 16, 2024@18:21:45 Page 2
IBCVC ;ALB/WCJ - VALUE CODE FUNCTIONALITY ;25-JUN-07
+1 ;;2.0;INTEGRATED BILLING;**371,400,432,718,732,742**;21-MAR-94;Build 36
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 GOTO AWAY
AWAY QUIT
+1 ;
ALLOWVC(IBIFN,Y) ; see if the value code is obsolete.
+1 ; returns 0 = Not Allowed/Obsolete
+2 ; returns 1 = Allowed
+3 ;
+4 NEW OBSDT,SCF
+5 SET OBSDT=$$GET1^DIQ(399.1,Y,.26,"I")
+6 DO CLEAN^DILF
+7 ; If there is no obsolete date, were cool
if '+OBSDT
QUIT 1
+8 ;
+9 ; get the statement covers from date to compare with
SET SCF=$$GET1^DIQ(399,IBIFN,151,"I")
+10 DO CLEAN^DILF
+11 ; if there is none, not sure where to go with this. It's required so I say fail.
IF 'SCF
QUIT 0
+12 ;
+13 IF SCF>OBSDT
QUIT 0
+14 ;
+15 QUIT 1
+16 ;
HELP ;
+1 if '$GET(DA)
QUIT
+2 if '$GET(DA(1))
QUIT
+3 if '$DATA(^DGCR(399,DA(1),"CV",DA,0))
QUIT
+4 NEW VCPTR
+5 SET VCPTR=$PIECE($GET(^DGCR(399,DA(1),"CV",DA,0)),U)
+6 if VCPTR=""
QUIT
+7 if '$DATA(^DGCR(399.1,VCPTR,1))
QUIT
+8 NEW LOOP
+9 SET LOOP=0
FOR
SET LOOP=$ORDER(^DGCR(399.1,VCPTR,1,LOOP))
if '+LOOP
QUIT
Begin DoDot:1
+10 ; W !,$G(^(LOOP,0)) ;IB742;WCJ
+11 ;IB742;WCJ
DO EN^DDIOL($GET(^(LOOP,0)),"","!")
End DoDot:1
+12 QUIT
+13 ;
FORMCHK(X,DA) ; Check to make sure that the VALUE is in the correct format base on the VALUE CODE.
+1 ; This tag is the input transform for the VALUE field (Sub-File 399.047, field .02).
+2 ;
+3 ; X = data being verified
+4 ; DA = subfile entry
+5 ; DA(1) = IEN to 399
+6 ;
+7 ; returns
+8 ; 0 = invalid format
+9 ; 1 = valid format
+10 ;
+11 ; WCJ;IB*2.0*742;v4
if $LENGTH(X)<1
QUIT 0
+12 ; WCJ;IB*2.0*742;v4
if $LENGTH(X)>10
QUIT 0
+13 if '$GET(DA)
QUIT 0
+14 if '$GET(DA(1))
QUIT 0
+15 if '$DATA(^DGCR(399,DA(1),"CV",DA,0))
QUIT 0
+16 ;
+17 NEW VCPTR
+18 SET VCPTR=$PIECE($GET(^DGCR(399,DA(1),"CV",DA,0)),U)
+19 if VCPTR=""
QUIT 0
+20 ;
+21 QUIT $$CHK(VCPTR,X)
+22 ;
CHK(VCPTR,X) ; This tag is called from the input transform above and also from the IB edit check routines (IBCBB*)
+1 ; This function is passed in:
+2 ; VCPTR - pointer into file #399.1
+3 ; X - the VALUE being checked
+4 ; Returns:
+5 ; 0 or false - Invalid format or can't figure it out.
+6 ; 1 or true - valid format (or in the case of 24, defined at the state level)
+7 ;
+8 NEW CODE,OK
+9 SET CODE=$$GET1^DIQ(399.1,VCPTR_",",.02,"I")
+10 DO CLEAN^DILF
+11 if CODE=""
QUIT 0
+12 ;
+13 NEW AMTFLG
+14 ;
+15 ; Check to see if it goes out as a monetary amount.
+16 SET AMTFLG=$$GET1^DIQ(399.1,VCPTR_",",.19,"I")
+17 DO CLEAN^DILF
+18 IF AMTFLG
QUIT X?1(1.7N,.7N1"."1.2N)
+19 ;
+20 ; Medicaid Rate Code (This is defined at the state level)
+21 ;TPF;IB*2.0*718;EBILL-1570;11/22/2021
+22 IF CODE=24
QUIT X?1.9AN&'(X?2"0"."0")
+23 ;Q:CODE=24 1
+24 ;
+25 ; Accident Hour
+26 IF CODE=45
QUIT ".00.01.02.03.04.05.06.07.08.09.10.11.12.13.14.15.16.17.18.19.20.21.22.23.99."[("."_X_".")
+27 ;
+28 ; Whole Numbers
+29 ;TPF;IB*2.0*718;EBILL-1570;11/22/2021 ADD NEW VC WHOLE NUMBERS (NUMERIC STRING)
+30 IF ".G8.62.63.32.37.38.39.46.50.51.52.53.56.57.58.59.67.68.69.80.81.82.83.84."[("."_CODE_".")
QUIT X?1.7N&'(X?2"0"."0")
+31 IF ".D4."[("."_CODE_".")
QUIT X?1.9N&'(X?2"0"."0")
+32 ;I ".37.38.39.46.50.51.52.53.56.57.58.59.67.68.80.81.82."[("."_CODE_".") Q X?1.7N
+33 ;
+34 ; Zip
+35 IF CODE="A0"
QUIT X?5N&'(X?5"0")
+36 ;
+37 ;I ".48.49."[("."_CODE_".") S OK=1 D Q OK
+38 ;I ".54.48.49.A8.A9.D5."[("."_CODE_".") S OK=1 D Q OK ;TPF;IB*2.0*718;EBILL-1570;11/22/2021 ADD NEW VC DECIMAL NUMBERS (DECIMALS)
+39 ;. I $P(X,".")'?.2N S OK=0 Q
+40 ;. I $P(X,".",2,999)'?.1N S OK=0 Q
+41 ;. I $E(X,$L(X))="." S OK=0 Q
+42 ;ISSUE P718 DEAL WITH DECIMALS
+43 SET OK=0
+44 ;HEMOGLOBIN AND HEMATOCRIT NN.NN
IF ".48.49."[("."_CODE_".")
Begin DoDot:1
+45 SET OK=(X?1.2N.1".".2N)&(X'?3.N)&($EXTRACT(X,$LENGTH(X))'=".")
End DoDot:1
QUIT OK
+46 ;
+47 ;HEIGHT AND WEIGHT NNN.NN weight in Kg, Height in cm
IF ".A8.A9."[("."_CODE_".")
Begin DoDot:1
+48 SET OK=(X?1.3N.1".".2N)&(X'?4.N)&($EXTRACT(X,$LENGTH(X))'=".")
End DoDot:1
QUIT OK
+49 ;
+50 ;LAST KT NN.NN
IF ".D5."[("."_CODE_".")
Begin DoDot:1
+51 SET OK=(X?1.2N1".".2N)&($EXTRACT(X,$LENGTH(X))'=".")
End DoDot:1
QUIT OK
+52 ;
+53 ;NEWBORN WEIGHT NNNN.NN
IF ".54."[("."_CODE_".")
Begin DoDot:1
+54 SET OK=(X?1.4N.1".".2N)&(X'?5.N)&($EXTRACT(X,$LENGTH(X))'=".")
End DoDot:1
QUIT OK
+55 ;END DECIMALS
+56 ;
+57 ; Alpha Numeric, no punctuation
+58 IF ".60.61."[("."_CODE_".")
QUIT X?1.7AN&'(X?2"0"."0")
+59 QUIT 1
+60 ;
+61 ;TPF;IB*2.0*718;EBILL-1570;11/22/2021
PATCH718CHK(IEN) ;EP - CALLED FROM KIDS BUILD DATA SCREEN FOR FILE #399.1
+1 IF (U_58_U_79_U_80_U_642_U_643_U_639_U_678_U_689_U)[(U_IEN_U)
QUIT 1
+2 IF $$NUMRANGE(IEN,60,62)
QUIT 1
+3 IF $$NUMRANGE(IEN,45,47)
QUIT 1
+4 IF $$NUMRANGE(IEN,74,76)
QUIT 1
+5 IF $$NUMRANGE(IEN,82,84)
QUIT 1
+6 IF $$NUMRANGE(IEN,86,91)
QUIT 1
+7 IF $$NUMRANGE(IEN,94,99)
QUIT 1
+8 IF $$NUMRANGE(IEN,102,104)
QUIT 1
+9 IF $$NUMRANGE(IEN,265,268)
QUIT 1
+10 IF $$NUMRANGE(IEN,587,590)
QUIT 1
+11 IF $$NUMRANGE(IEN,634,638)
QUIT 1
+12 QUIT 0
+13 ;
+14 ;TPF;IB*2.0*718;EBILL-1570;11/22/2021
NUMRANGE(X,LOW,HIGH) ;EP - NUMBER RANGE CHECK
+1 ;RETURNS 1 IF X LIES WITHIN NUMBER RANGE
+2 IF (X=LOW!(X>LOW))
IF (X<HIGH!(X=HIGH))
QUIT 1
+3 QUIT 0
+4 ;
+5 ;
+6 ;#.02 CODE #399.1 MCCR UTILITY ^ #.02 VALUE #399.047 VALUE CODE #399 BILL/CLAIMS ^ #.19 VALUE CODE AMOUNT #399.1 MCCR UTILITY ^ VALUE CODE IEN #399.1
+7 ;IBXSAVE("VALUE",1)="48^15^0^92"
+8 ;IBXSAVE("VALUE",2)="49^45.2^0^93"
+9 ;IBXSAVE("VALUE",3)="A9^32.9^^592"
+10 ;IBXSAVE("VALUE",4)="A8^60^^591"
+11 ;IBXSAVE("VALUE",5)="A3^22691.94^1"
+12 ;
+13 ;USE THIS IN PLACE OF CALL TO $$DOLLAR IN FILE #FORMAT CODE
VALCODEFMT(IBSAVE,IBDATA) ;EP - TAKE VALUE CODE ARRAY AND FORMAT EACH ACCORDINGTO DATA TYPE
+1 ;WCJ;IB718;SQA
NEW DOLLARAMT,VALCODEIEN,VALCODENAME,VALUE,DATATYPE
+2 NEW TESTING
+3 ;SET TO ONE IF TESTING TO SHOW DISPLAY HELPERS
SET TESTING=0
+4 if '$ORDER(IBSAVE("VALUE",""))
QUIT
+5 if $GET(TESTING)
WRITE !?25,"VC1-VC24 AMT FIELD"
+6 if $GET(TESTING)
WRITE !?25,"|123456789|",?40,"VALUE CODE",?55,"VALUE CODE NAME"
+7 if $GET(TESTING)
WRITE !?25,"-----------"
+8 NEW IEN
+9 SET IEN=0
+10 FOR
SET IEN=$ORDER(IBSAVE("VALUE",IEN))
if 'IEN
QUIT
Begin DoDot:1
+11 SET VALUECODE=$PIECE(IBSAVE("VALUE",IEN),U)
+12 ;SUBFILE #399.047 FIELD #.02 OF FILE #399
SET VALUE=$PIECE(IBSAVE("VALUE",IEN),U,2)
+13 ;FILE #399.1 MCCR UTILITY FIELD #.19 VALUE CODE AMOUNT
SET DOLLARAMT=$PIECE(IBSAVE("VALUE",IEN),U,3)
+14 SET VALCODEIEN=$PIECE(IBSAVE("VALUE",IEN),U,4)
+15 IF 'VALCODEIEN
SET VALCODEIEN=$ORDER(^DGCR(399.1,"C",VALUECODE,0))
+16 SET VALCODENAME=""
+17 if VALCODEIEN
SET VALCODENAME=$PIECE($GET(^DGCR(399.1,VALCODEIEN,0)),U)
+18 ;
+19 IF DOLLARAMT
SET IBDATA(IEN)=$$FMTDOLLAR(VALUE)
QUIT
+20 ;
+21 ;IF ITS NOT EXPLICITLY DECLARED A DOLLAR AMOUNT BY THE SETTING OF FIELD #.19 THE WE NEED TO DETERMINE
+22 ;THE DATA TYPE AND LOOK AT THE ALLOWED VALUE FORMATS BASED ON THE HISTORICAL CODE IN CHK^.
+23 ;
+24 SET DATATYPE=$$DATATYPE(VALUECODE,VALUE,0)
+25 IF DATATYPE="FMTNUMERIC"
SET IBDATA(IEN)=$$FMTNUMERIC(VALUE)
QUIT
+26 IF DATATYPE="FMTALPHANUM"
SET IBDATA(IEN)=$$FMTALPHANUM(VALUE)
QUIT
+27 IF DATATYPE="FMTDECIMAL"
SET IBDATA(IEN)=$$FMTDECIMAL(VALUE)
QUIT
+28 IF '$TEST
SET IBDATA(IEN)=$$FMTSPECIAL(VALUE,VALUECODE)
QUIT
End DoDot:1
+29 if $GET(TESTING)
WRITE !?25,"-----------"
+30 if $GET(TESTING)
WRITE !!
+31 QUIT
+32 ;
+33 ;LENGTH = SIZE OF FORMAT FIELD
+34 ;JUST ="L" = LEFT JUSTIFIED
+35 ;JUST = "R" = RIGHT JUSTIFIED
+36 ;DECPT = 0 = DECIMAL PT IMPLIED
+37 ;DECPT = 1 = DECIMAL PT ADDED
+38 ;FILLCHAR = CHARACTER TO USE AS A FILLER
+39 ;
+40 ;W $$FORMAT^IBCVC("23.",8,"L",1," ",2)
+41 ;THIS IS NOT FOR ANY PRINTED FORM
FORMAT(DATA,LENGTH,JUST,DECPT,FILLCHAR,PRECISION,DATATYPE) ;EP - FORMAT PER SPECS
+1 ;
+2 ;WCJ;IB718;SQA
NEW FILL
+3 NEW FILLER
+4 SET JUST=$$UP^XLFSTR($GET(JUST))
+5 SET FILL='$GET(FILLCHAR)=""
+6 SET DATA=$$ABS^XLFMTH(DATA)
+7 SET LENGTH=$GET(LENGTH)
+8 SET DECPT=$GET(DECPT)=1
+9 ;
+10 IF PRECISION
SET DATA=$JUSTIFY(VALUE,LENGTH,PRECISION)
if 'DECPT
SET DATA=$TRANSLATE(DATA,".")
+11 ;
+12 IF FILLCHAR=""
SET DATA=$$TRIM^XLFSTR(DATA,"LR")
QUIT DATA
+13 ;
+14 IF JUST="R"
SET DATA=$$RJ^XLFSTR(DATA,LENGTH,FILLCHAR)
+15 IF '$TEST
SET DATA=$$LJ^XLFSTR(DATA,LENGTH,FILLCHAR)
+16 QUIT DATA
+17 ;
FMTDOLLAR(VALUE) ;EP - FORMAT DOLLAR AMOUNTS
+1 SET VALUE=$$FORMAT(VALUE,9,"R",1,"",2)
+2 if $GET(TESTING)
WRITE !,"DATATYPE DOLLAR:",?25,"|",VALUE_"|"
+3 if $GET(TESTING)
WRITE ?45,VALUECODE,?55,$EXTRACT(VALCODENAME,1,25)
+4 QUIT VALUE
+5 ;
FMTNUMERIC(VALUE,DATATYPE) ;EP - FORMAT NUMERIC STRING
+1 SET VALUE=$$FORMAT^IBCVC(VALUE,7,"R",0,"",0)
+2 if $GET(TESTING)
WRITE !,"DATATYPE NUMERIC:",?25,"|",VALUE_"|"
+3 if $GET(TESTING)
WRITE ?45,VALUECODE,?55,$EXTRACT(VALCODENAME,1,25)
+4 QUIT VALUE
+5 ;
FMTALPHANUM(VALUE) ;EP - FORMAT ALPHANUMERICS
+1 SET VALUE=$$FORMAT^IBCVC(VALUE,7,"R",0,"",0)
+2 if $GET(TESTING)
WRITE !,"DATATYPE ALPHANUM:",?25,"|",VALUE_"|"
+3 if $GET(TESTING)
WRITE ?45,VALUECODE,?55,$EXTRACT(VALCODENAME,1,25)
+4 QUIT VALUE
+5 ;
FMTDECIMAL(VALUE) ;EP - FORMAT DECIMALS
+1 ;S VALUE=$$FORMAT^IBCVC(VALUE,$L(VALUE),"R",1,"",1,"FMTDECIMAL")
+2 ;TPF;IB*732
SET VALUE=$$FORMAT^IBCVC(VALUE,$LENGTH(VALUE),"R",1,"",2,"FMTDECIMAL")
+3 if $GET(TESTING)
WRITE !,"DATATYPE DECIMAL:",?25,"|",VALUE_"|"
+4 if $GET(TESTING)
WRITE ?45,VALUECODE,?55,$EXTRACT(VALCODENAME,1,25)
+5 QUIT VALUE
+6 ;
+7 ;SPECIAL CASES
FMTSPECIAL(VALUE,VALUECODE) ;EP - SPECIAL CASE FORMAT
+1 if $GET(VALUECODE)=""
QUIT VALUE
+2 IF VALUECODE="45"
SET VALUE=$$FORMAT(VALUE,7,"R",0,"",0,"FMTNUMERIC")
+3 IF VALUECODE="A0"
SET VALUE=$$FORMAT(VALUE,7,"R",1,"",0,"FMTNUMERIC")
+4 IF VALUECODE=24
SET VALUE=$$FORMAT(VALUE,8,"R",1,"",0,"FMTALPHANUM")
+5 if $GET(TESTING)
WRITE !,"DATATYPE SPECIAL:",?25,"|"_VALUE_"|"
+6 if $GET(TESTING)
WRITE ?45,VALUECODE,?55,$EXTRACT(VALCODENAME,1,25)
+7 QUIT VALUE
+8 ;
+9 ;VALUE CODE DATATYPE DEFINITIONS
DATATYPE(CODE,VALUE,INPUTCHK) ;EP - WHAT TYPE OF DATA DOES IB IDENTIFIY THIS VALUE CODE TO BE
+1 IF $$NUMERIC(VALUECODE,VALUE,INPUTCHK)
QUIT "FMTNUMERIC"
+2 IF $$DECIMALS(VALUECODE,VALUE,INPUTCHK)
QUIT "FMTDECIMAL"
+3 IF $$ALPHANUM(VALUECODE,VALUE,INPUTCHK)
QUIT "FMTALPHANUM"
+4 IF $$ZIPCODE(VALUECODE,VALUE,INPUTCHK)
QUIT "FMTALPHANUM"
+5 QUIT "SPECIAL"
+6 ;
NUMERIC(CODE,VALUE,INPUTCHK) ;EP - IS VALUE CODE WHOLE NUMBER AS DEFINED HISTORICALLY IN CHK^IBCVC
+1 IF (U_"G8"_U_"D4"_U_62_U_63_U_32_U_37_U_38_U_39_U_46_U_50_U_51_U_52_U_53_U_56_U_57_U_58_U_59_U_67_U_68_U_69_U_80_U_81_U_82_U_83_U_84_U)[(U_CODE_U)
+2 if '$GET(INPUTCHK)
QUIT $TEST
+3 QUIT VALUE?1.7N&'(X?2"0"."0")
+4 ;
ALPHANUM(CODE,VALUE,INPUTCHK) ;EP - IS VALUE CODE AN ALPHANUMERIC?
+1 IF (U_60_U_61_U)[(U_CODE_U)
+2 if '$GET(INPUTCHK)
QUIT $TEST
+3 QUIT VALUE?1.7AN&'(X?2"0"."0")
+4 ;
DECIMALS(CODE,VALUE,INPUTCHK) ;EP - IS VALUE CODE A "DECIMAL" AS DEFINED HISTORICALLY IN CHK^IBCVC
+1 IF (U_54_U_48_U_49_U_"A8"_U_"A9"_U_"D5"_U)[(U_CODE_U)
+2 if '$GET(INPUTCHK)
QUIT $TEST
+3 ;
+4 SET OK=1
Begin DoDot:1
+5 IF $PIECE(X,".")'?.2N
SET OK=0
QUIT
+6 IF $PIECE(X,".",2,999)'?.1N
SET OK=0
QUIT
+7 IF $EXTRACT(X,$LENGTH(X))="."
SET OK=0
QUIT
End DoDot:1
QUIT OK
+8 QUIT 0
+9 ;
ZIPCODE(CODE,VALUE,INPUTCHK) ;EP - RETURN IF VALID ZIP IN FILE #5.11 ZIP CODE
+1 IF (U_"A0"_U)[(U_CODE_U)
+2 if '$GET(INPUTCHK)
QUIT $TEST
+3 QUIT X?5N
+4 ;I KNOW THIS IS OUT OF SCOPE BUT....
+5 ;PER BILL DO NOT INCLUDE
+6 ;DATE SHOULD BE DATE OF SERVICE NOT DATE BILL IS ENTERED?
+7 ;D ZIPCODE^DSICXIP(.RETURN,ZIPCODE,DT,1) ;DOES THIS NEED A ICR#
+8 ;RETURN="-1^Postal Code cannot be found"
+9 ;RETURN="87015^EDGEWOOD^NEW MEXICO^SANTA FE^35049^NM^35^2844"
+10 QUIT $GET(RETURN)>0
+11 ;
REMOVE(DA) ; Remove the VALUE field since it's in the wrong format.
+1 ; This is called from a NEW STYLE X-REF "AC" in file 399.047 field .01
+2 NEW IENS,FDA
+3 if '$GET(DA)!'$GET(DA(1))
QUIT
+4 SET IENS=DA_","_DA(1)_","
+5 SET FDA(399.047,IENS,.02)="@"
+6 DO FILE^DIE(,"FDA")
+7 DO CLEAN^DILF
+8 QUIT
+9 ;
COND(DA,OLDVC,NEWVC) ; Check if the VALUE is in a valid format for the new VALUE CODE.
+1 ; This is called from a NEW STYLE X-REF "AC" in file 399.047 field .01
+2 ; This function will return:
+3 ; 1 - Means that this VALUE should be deleted (It's in the wrong format)
+4 ; 0 - Means that this VALUE should NOT be deleted
+5 if '$GET(OLDVC)
QUIT 0
+6 if '$GET(DA)!'$GET(DA(1))
QUIT 0
+7 NEW OLDVALUE
+8 SET OLDVALUE=$PIECE($GET(^DGCR(399,DA(1),"CV",DA,0)),U,2)
+9 if OLDVALUE=""
QUIT 0
+10 QUIT '$$CHK(NEWVC,OLDVALUE)
+11 ;
+12 ;IB*2.0*432 - TAZ - VC1 added
VC1(IBXIEN,IBFL) ;Code for the VC1 record of the IB 837 Transmission
+1 ;INPUT:
+2 ;IBXIEN - IEN of bill/claim file
+3 ;IBFL - output array passed by reference
+4 ;
+5 ;OUTPUT:
+6 ;IBFL - array contains the list of value codes to be included in the transmission
+7 ;
+8 NEW IBI,IBX,Z,Z0,INST
+9 SET INST=$$FT^IBCEF(IBXIEN)=3
+10 SET (IBI,IBX)=0
FOR
SET IBX=$ORDER(^DGCR(399,IBXIEN,"CV",IBX))
if 'IBX
QUIT
Begin DoDot:1
+11 SET Z=$GET(^(IBX,0))
SET Z0=$GET(^DGCR(399.1,+Z,0))
+12 IF Z0=""
QUIT
+13 IF ",A3,B3,C3,"[(","_$PIECE(Z0,U,2)_",")
IF INST
QUIT
+14 SET IBI=IBI+1
SET IBFL(39,IBI)=$PIECE(Z0,U,2)_U_$PIECE(Z,U,2)_U_$PIECE(Z0,U,12)_U_+Z
End DoDot:1
+15 IF INST
Begin DoDot:1
+16 SET CODE=$PIECE("A3^B3^C3",U,$$COBN^IBCEF(IBXIEN))
+17 SET Z=$GET(^DGCR(399,IBXIEN,"U1"))
SET Z0=Z-$PIECE(Z,U,2)
+18 SET IBI=IBI+1
SET IBFL(39,IBI)=CODE_U_Z0_U_1
End DoDot:1
+19 QUIT
+20 ;
+21 ;TPF;IB*2.0*718;EBILL-1570;11/03/2021
+22 ;D VCSCREEN^IBCVC
VCSCREEN(X) ;EP - FIELD #2 VALUE CODE AMOUNT SCREEN, FILE #399.1 MCCR UTILITY INPUT TRANSFORM
+1 ;THE PURPOSE OF THIS INPUT TRANSFORM IS TO ALLOW THE USER TO EASILY PICK STANDARD VALUE AMOUNT screens
+2 ;CHECK FOR VALUE CODE TYPE ENTRIES
IF $PIECE(@DILK@(0),U,11)'=1
Begin DoDot:1
+3 KILL X
+4 DO BMES^XPDUTL(" ")
+5 DO MES^XPDUTL("ONLY 'VALUE CODE' ENTRIES CAN BE GIVEN A 'VALUE CODE AMOUNT SCREEN'")
End DoDot:1
QUIT
+6 ;
+7 IF $GET(DUZ(0))'="@"
WRITE !!,"PROGRAMMER ONLY EDITABLE FIELD!!!"
HANG 1
QUIT
+8 ;
+9 NEW MCODE
+10 SET MCODE=X
+11 ;CHECK THE INCOMING X FOR VALID MUMPS CODE
DO ^DIM
+12 IF $DATA(X)
Begin DoDot:1
+13 WRITE !!,"This is valid MUMPS code."
+14 WRITE !!,X
+15 WRITE !
+16 NEW DIR,X
+17 SET DIR(0)="Y"
+18 SET DIR("B")="Y"
+19 SET DIR("A")="Is this is the screen for "_$PIECE($GET(^DGCR(399.1,91,0)),U)
+20 DO ^DIR
End DoDot:1
if $GET(Y)
QUIT
+21 IF '$TEST
Begin DoDot:1
+22 WRITE !!,"The following code is not valid MUMPS code"
+23 WRITE !!,$GET(MCODE)
+24 WRITE !!,"Try a standard VALUE CODE AMOUNT screen or enter valid MUMPS code."
End DoDot:1
+25 ;
+26 ;IS THIS A DOLLAR AMOUNT?
NEW DOLLAR
SET DOLLAR=$PIECE(@DILK@(0),U,12)=1
+27 ;
+28 NEW DIR,DIE,DIC,DA,DR,DIK,DTOUT,DUOUT,DIROUT,Y
+29 NEW ERRORCODE,MCODE
+30 SET DIR(0)="SO^"
+31 ;DEFAULT CHOICE - LIKELY THE MOST OFTEN USED EDIT CHECK FOR ALL NEW IB VALUE CODES
SET DIR("B")="="
+32 ;COLLECT STANDARD CHOICES
DO STANCHOICE(.DIR,.MCODE)
+33 ;
+34 IF DUZ(0)="@"
SET DIR(0)=DIR(0)_"M:ENTER MY OWN MUMPS CODE"
+35 SET DIR("A")="CHOOSE A STANDARD VALUE AMOUNT EDIT CHECK"
+36 DO ^DIR
+37 ; Y=">"
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(Y="")
KILL X
QUIT
+38 ;
+39 IF Y'="M"
Begin DoDot:1
+40 ;ASK USER FOR #350.8 'IB ERROR' ASSOCIATED WITH THIS VALUE CODE AMOUNT EDIT CHECK
DO ASKFORERROR(.ERRORCODE,Y)
+41 IF $GET(ERRORCODE)=""
KILL X
QUIT
+42 ; Y(0)="IF VCVALUE>0"
SET X=$$ADDWRAPPER($GET(MCODE(Y)),ERRORCODE)
End DoDot:1
QUIT
+43 ;
+44 DO MUMPSCODE(.X)
+45 QUIT
+46 ;
MUMPSCODE(MUMPSCODE) ;EP - GET NON-STANDARD MUMPS CODE FOR CODE VALUE AMOUNT EDIT CHECK
+1 DO BMES^XPDUTL(" ")
+2 DO MES^XPDUTL("REMEMBER TO UTILIZE THE STANDARD VARIABLE 'IBVCVALUE'")
+3 DO MES^XPDUTL("REMEMBER TO SET THE VARIABLE 'IBVCERR' TO 1 ON AN ERROR CONDITION.")
+4 DO MES^XPDUTL("REMEMBER TO CALL $$IBER^IBCBB3 TO SET THE ERROR LIST.")
+5 DO MES^XPDUTL("REMEMBER TO REFERNCE YOUR NEW IB ERROR CODE PROPERLY TOO.")
+6 DO MES^XPDUTL("EXAMPLE:")
+7 DO BMES^XPDUTL("Q:$G(IBVCVALUE)="""" I IBVCVALUE<5,$G(IBER)'[(""9999;"") S IBQUIT=$$IBER^IBCBB3(.IBER,9999),IBVCERR=1")
+8 DO BMES^XPDUTL(" ")
+9 ;
+10 NEW DIR,DIE,DIC,DA,DR,DIK,DTOUT,DUOUT,DIROUT,Y
+11 SET DIR(0)="FOU^0:245^Q:X="""" D:$D(X) ^DIM Q:'$D(X) K:X'[(""IBVCVALUE"")&(X'[(""IBVCERR"")) X"
+12 SET DIR("A")="Enter MUMPS Edit Check Code"
+13 SET DIR("?")="Code cannot be >245 characters, must be legal MUMPS code and reference IBVCVALUE and IBVCERR"
+14 DO ^DIR
+15 IF X="@"
KILL X
+16 QUIT
+17 ;
ASKFORERROR(ERROR,STANCHOICE) ;EP - ASK FOR ERROR
+1 NEW DIR,DIE,DIC,DA,DR,DIK,DTOUT,DUOUT,DIROUT,X,Y
REDO ;
+1 DO BMES^XPDUTL(" ")
+2 DO MES^XPDUTL("You must associate an IB ERROR error code to this error condition.")
+3 DO MES^XPDUTL("For now, If you need a new error code you must create one separtely.")
+4 DO BMES^XPDUTL(" ")
+5 SET DIC="^IBE(350.8,"
+6 SET DIC(0)="AEMQZ"
+7 DO ^DIC
+8 if X=U!(X="")
QUIT
+9 if Y<0
GOTO REDO
+10 SET ERROR=$PIECE($PIECE($PIECE(Y,U,2),"IB",2)," ")
+11 QUIT
+12 ;
ADDWRAPPER(CODESTR,ERRORCODE) ;EP - ADD BASIC CODE TOCHECKFOR VALUE AND ADD STANDARD IBER CALL
+1 NEW PREFIX,SUFFIX
+2 ;"Q:$G(IBVCVALUE)="""" " NO VALUE CHECK IS HARDCODED IN IBCBB5
SET PREFIX=""
+3 SET SUFFIX=",$G(IBER)'[("""_ERRORCODE_";"") S IBQUIT=$$IBER^IBCBB3(.IBER,"_ERRORCODE_"),IBVCERR=1"
+4 SET CODESTR=PREFIX_CODESTR_SUFFIX
+5 QUIT CODESTR
+6 ;
STANCHOICE(DIR,MCODE) ;EP-PULL STANDARD (OR EASY USER) CHOICES
+1 ;WCJ;IB718;SQA
NEW CHOICE,SETCODE
+2 NEW OFFSET
+3 FOR OFFSET=1:1
SET CHOICE=$PIECE($TEXT(STANCHOICES+OFFSET),";;",2)
if CHOICE="STOP"
QUIT
Begin DoDot:1
+4 SET MCODE=$PIECE(CHOICE,"|",2)
+5 SET CHOICE=$PIECE(CHOICE,"|")
+6 SET SETCODE=$PIECE(CHOICE,":")
+7 SET MCODE(SETCODE)=MCODE
+8 SET DIR(0)=$GET(DIR(0))_CHOICE_";"
End DoDot:1
+9 QUIT
+10 ;
+11 ;ADD STANDARD EASY CHOICES HERE SO YOU DON'T HAVE TO ADD THEM TO THE DIR(0) STRING MANUALLY
+12 ;SHORCUT:USER READABLE PSEUDO CODE | MUMPS CODE
STANCHOICES ;;
+1 ;;=0:ONLY ZERO ALLOWED|I $G(IBVCVALUE)'=0
+2 ;;>0:IF VALUE CODE AMOUNT GREATER THAN ZERO THEN ERROR|I +$G(IBVCVALUE)>0
+3 ;;<0:IF VALUE CODE AMOUNT LESS THAN ZERO THEN ERROR|I +$G(IBVCVALUE)<0
+4 ;;=:IF VALUE CODE AMOUNT EQUALS ZERO THEN ERROR|I +$G(IBVCVALUE)=0|IB916
+5 ;;<sp>:IF VALUE CODE AMOUNT EQUALS A SPACE THEN ERROR|I $G(IBVCVALUE)=""
+6 ;;'<sp>:IF VALUE CODE AMOUNT EQUALS NOT EQUAL A SPACE THEN ERROR|I $G(IBVCVALUE)'=""
+7 ;;STOP
+8 QUIT
