- 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 Feb 18, 2025@23:47:29 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