Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCVC

IBCVC.m

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