- IBCU7 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
- ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348,371,432,447,488,461,516,522,577,604,616,592,608,714,742**;21-MAR-94;Build 36
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;MAP TO DGCRU7
- ;
- ; This routine is a copy of IBUC7 for testing purposes.
- ;
- CHKX ; -interception of input x from Additional Procedure input
- G:X=" " CHKXQ
- I $$INPAT^IBCEF(DA(1)),'$P($G(^IBE(350.9,1,1)),"^",15),X'?1A1.2N D G CHKXQ
- . K X
- . D EN^DDIOL("Site param does not allow entry of non-PTF procedures") ;Fileman error here will be: The previous error occurred when performing an action specified in a Pre-lookup transform (7.5 node).
- G:'$D(^UTILITY($J,"IB")) CHKXQ
- ;S M=($A($E(X,1))-64),S=+$E(X,2) Q:'$G(^UTILITY($J,"IB",M,S)) S X="`"_+^(S)
- S M=0 I X?1A1.2N S N=$G(^UTILITY($J,"IB","B",X)) S M=+N,S=+$P(N,U,2),P=X S S=$G(^UTILITY($J,"IB",M,S)) I +S S X="`"_+S I $P(N,U,3)="N" S X=""""_X_"""" S $P(^UTILITY($J,"IB","B",P),U,3)="Y"
- I +M,$D(DGPROCDT),DGPROCDT'=$P($G(^UTILITY($J,"IB",M,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) W !!,"Procedure Date: " S Y=DGPROCDT X ^DD("DD") W Y,!
- CHKXQ Q
- ;
- CODMUL ;Date oriented entry of procedure
- DELASK I $D(IBZ20),IBZ20,IBZ20'=$P(^DGCR(399,IBIFN,0),U,9) S %=2 W !,"SINCE THE PROCEDURE CODING METHOD HAS BEEN CHANGED, DO YOU WANT TO DELETE ALL",!,"PROCEDURE CODES IN THIS BILL"
- I D YN^DICN Q:%=-1 D:%=1 DELADD I %Y?1."?" W !!,"If you answer 'Yes', all procedure codes will be DELETED from this bill.",! G DELASK
- K %,%Y,DA,IBZ20,DIK ;W !,"Procedure Entry:"
- ;
- CODDT I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
- I $P($G(^DGCR(399,IBIFN,0)),"^",5)<3 S IBZTYPE=1 I $P($G(^UTILITY($J,"IB",1,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) D ASKCOD
- S X=$$PRCDIV^IBCU71(IBIFN) I +X W !!,$P(X,U,2),!
- N IBINDTS,Z,Z0 S Z=$G(^DGCR(399,IBIFN,"U")),IBINDTS=+$P($G(^DGCR(399,IBIFN,0)),U,28) ; IB*2.0*714
- S Z0=$$FMTE^XLFDT($S(IBINDTS>0:IBINDTS,1:$P(Z,U)),"2D")_"-"_$$FMTE^XLFDT($P(Z,U,2),"2D") ; ; IB*2.0*714
- W !,"Select PROCEDURE DATE"_$S($TR(Z0,"-")'="":" ("_Z0_")",1:"")_": " R X:DTIME G:'$T!("^"[X) CODQ D:X["?" CODHLP
- S IBEX=0 D ; Get procedure date
- . I X=" ",$D(DGPROCDT),DGPROCDT?7N S Y=DGPROCDT D D^DIQ W " (",Y,")" Q
- . I X=" ",+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4) S (DGPROCDT,Y)=$O(^DGCR(399,IBIFN,"OP",0)) D D^DIQ W " (",Y,")" Q
- . S %DT="EXP",%DT(0)=-DT D ^%DT K %DT I Y<1 S IBEX=1 Q
- . I '$$OPV2^IBCU41(Y,IBIFN,1) S IBEX=1 Q
- . S:'$G(IBZTYPE) X=$$OPV^IBCU41(Y,IBIFN) S DGPROCDT=Y
- I 'IBEX D ASKCOD,ADDCPT^IBCU71:$D(DGCPT)
- K IBEX
- G CODDT
- ;
- ASKCOD N Z,Z0,DA,IBACT,IBQUIT,IBLNPRV,IBCODE,IBPIEN ;WCJ;2.0*432
- N IBPOPOUT S IBPOPOUT=0 ; IB*2.0*447 BI
- K DGCPT
- S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^",19),DGADDVST=0,IBFT=$P($G(^DGCR(399,IBIFN,0)),"^",19)
- I '$D(^DGCR(399,IBIFN,"CP",0)) S ^DGCR(399,IBIFN,"CP",0)=U_$$GETSPEC^IBEFUNC(399,304)
- ;
- F S IBQUIT=0 D Q:IBQUIT
- . S IBPOPOUT=0
- . D DICV ; restrict code type to PCM
- . S DIC("A")=" Select PROCEDURE: "
- . S DIC="^DGCR(399,"_IBIFN_",""CP"","
- . S DIC(0)="AEQMNL"
- . S DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCDT)"
- . S DIC("DR")="1///^S X=DGPROCDT"
- . S DA(1)=IBIFN,DLAYGO=399
- . W ! D ^DIC I Y<1 S IBQUIT=1 Q
- . S IBPROCP=+Y
- . S IBCODE="" I Y["ICPT" S IBPIEN=+$P(Y,U,2),IBCODE=$P($$CPT^ICPTCOD(IBPIEN),U,2) ;IB*2.0*616, get procedure code, supported by ICR 1995
- . ; If we just added inactive code - it must be deleted.
- . S IBACT=0 ; Active flag
- . I Y["ICD0" S IBACT=$$ICD0ACT^IBACSV(+$P(Y,U,2),$$BDATE^IBACSV(IBIFN))
- . I Y["ICPT" S IBACT=$$CPTACT^IBACSV(+$P(Y,U,2),DGPROCDT)
- . S DGCPTNEW=$P(Y,"^",3) ;Was the procedure just added?
- . I DGCPTNEW,'IBACT D DELPROC Q
- . I 'IBACT W !,*7,"Warning: Procedure code is inactive on this date",!
- . I DGCPTNEW,$D(^UTILITY($J,"IB")),$$INPAT^IBCEF(IBIFN),Y["ICPT(" D DATA^IBCU74(Y,.IBLNPRV)
- . S DGADDVST=$S(DGCPTNEW:1,$D(DGADDVST):DGADDVST,1:0)
- . N IBPRV,IBPRVO,IBPRVN
- . ;
- . ; Line level provider function by form type.
- . ; CMS-1500 (FORM TYPE=2)
- . ; RENDERING PROVIDER, REFERRING PROVIDER,
- . ; and SUPERVISING PROVIDER.
- . ; UB-04 (FORM TYPE=3)
- . ; RENDERING PROVIDER, REFERRING PROVIDER,
- . ; OPERATING PROVIDER, and OTHER OPERATING
- . ; PROVIDER.
- . ;
- . ; Removed: Call to $$MAINPRV^IBCEU(IBIFN) is for claim
- . ; level provider defaults.
- . ; 1. For new line level providers we don't need
- . ; or want default claim level provider
- . ; (requirement).
- . ; 2. We don't want to default claim level to
- . ; line level provider (requirement).
- . ;
- . K DIC("V") ; DEM;432 - KILL DIC("V") because this was for previous variable pointer use.
- . ;
- . N IBPROCSV ; DEM;432 - Variable IBPROCSV is variable to preserve value of 'Y', which is procedure code info returned by call to ^DIC.
- . S IBPROCSV=Y ; DEM;432 - Preserve value of Y for after calls to FileMan (Y = procedure code info returned by call to ^DIC).
- . K DR ;WCJ;IB*2.0*432
- . ;
- . I IBPROCSV["ICD0" S DR=".01",DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($D(Y)) K DR ; IB*2.0*461
- . ;
- . ;JRA;IB*2.0*608 Prompt user for Certificate of Medical Necessity (CMN) info
- . I $$FT^IBCEF(IBIFN)=2,$$CMNPRMT^IBJPS8(IBIFN,IBPROCP,$P($P(IBPROCSV,U,2),";")) D CMN^IBCU75(IBIFN,IBPROCP)
- . ;
- . ; WCJ;IB*2.0*742;change the modifier seq number prompt behavior
- . I IBPROCSV["ICPT" S DR=".01",DIE=DIC,(IBPROCP,DA)=$P(IBPROCSV,U) D ^DIE Q:'$D(DA)!($D(Y)) K DR D ; IB*2.0*447 BI ;WCJ;IB*2.0*742
- .. D EN^IBCU7C(IBPROCP)
- . ;
- . S DR=""
- . ;
- . ; MRD;IB*2.0*516 - Added line level PROCEDURE DESCRIPTION field,
- . ; asked only if the procedure is an "NOC".
- . I IBPROCSV["ICPT",$$NOCPROC(IBPROCSV,IBCODE,DGPROCDT) D ; added IBCODE,DGPROCDT in *604
- . . S DA=$P(IBPROCSV,"^") ; The line# on the bill/claim.
- . . S DR=51 ; Field# for PROCEDURE DESCRIPTION
- . . D ^DIE
- . . Q
- . ;
- . D EN^IBCU7B ; DEM;432 - Call to line level provider user input.
- . S Y=IBPROCSV ; DEM;432 - Restore value of Y after calls to FileMan
- . K IBPROCSV
- . K DR ;WCJ;IB*2.0*432
- . I IBPOPOUT Q ; IB*2.0*447 BI
- . S DR="" I Y["ICPT" S DR="6;5//"_$$DEFDIV(IBIFN)_";"
- . ;JWS;IB*2.0*592 US1108 - Dental
- . ;IA# 10018
- . S DR=DR_$S(IBFT=7:"8;",IBFT=2:"8;9;17//NO;",1:"")_3,DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($E($G(Y))=U)
- . K DR ;WCJ;IB*2.0*432
- . ;
- . ; MRD;IB*2.0*516 - Allow user to add an NDC and Units. Ask only if
- . ; coding system is not ICD and this is not a prescription claim. If
- . ; an NDC is entered, prompt for Units.
- . I $P($G(^DGCR(399,IBIFN,0)),U,9)'=9,'$$RXLINK^IBCSC5C(IBIFN,IBPROCP) D
- . . ;JWS;IB*2.0*592 US1108 - Dental
- . . I IBFT=7 Q
- . . K DA
- . . S DA=IBPROCP,DA(1)=IBIFN,DIE="^DGCR(399,"_IBIFN_",""CP"","
- . . ; vd/Beginning IB*2*577 - Added the prompt for Unit/Basis of Measurement.
- . . ; S DR="53NDC NUMBER;I X="""" S Y="""";54//1"
- . . S DR="53NDC NUMBER;I X="""" S Y="""";52R~//UN;54R~QUANTITY//1" ;Prompt for NDC, UN & amt.
- . . ; vd/Ending IB*2*577
- . . D ^DIE
- . . Q
- . ;
- . I IBFT=3 D:'$$INPAT^IBCEF(IBIFN) ATTACH ; DEM;432 - Prompt for Attachment Control Number.
- . ; DEM;432 - Add Additional OB Minutes to DR string for call to DIE.
- . S DR=$$SPCUNIT(IBIFN,IBPROCP) S:DR["15;" DR=DR_"74Additional OB Minutes" D ^DIE ; miles/minutes/hours
- . ;JWS;IB*2.0*592 US1108 - Dental
- . I IBFT=2!(IBFT=7) D
- .. D DX^IBCU72(IBIFN,IBPROCP)
- .. ;JWS;IB*2.0*592 US1108 - Dental
- .. I IBFT'=7 S X=$$ADDTNL(IBIFN,.DA)
- . Q:$$INPAT^IBCEF(IBIFN) ;only outpatient bills
- . ;JWS;IB*2.0*592 US1108 - Dental input fields
- . I IBFT=7 D ORAL^IBCU72
- . ;add procedures to array for download to PCE: dgcpt(assoc clinic,cpt,'provider^first dx^modifiers',cnt)=""
- . S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0))
- . S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,11),0))_U_$P(DGPROC,U,15)
- . I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2
- . I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^",7) S DGCPT($P(DGPROC,"^",7),+DGPROC,X,DGCPT)=""
- . ; add visit date to bill
- . I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K DINUM,X,DGNOADD,DGADDVST
- ; Delete modifiers with only a sequence #, no code
- S Z=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z S Z0=0 F S Z0=$O(^DGCR(399,IBIFN,"CP",Z,"MOD",Z0)) Q:'Z0 I $P($G(^(Z0,0)),U,2)="" S DA(2)=IBIFN,DA(1)=Z,DA=Z0,DIK="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD""," D ^DIK
- Q
- CODQ K %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO
- K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW
- Q
- ;
- DELPROC ; Remove the selected procedure, because of inactive status (cancel selection)
- W !!,*7,"The Procedure code is inactive on ",$$DAT1^IBOUTL(DGPROCDT),"."
- W !,"Please select another Procedure."
- S DA(1)=IBIFN,DA=+Y,DIK="^DGCR(399,"_IBIFN_",""CP"","
- D ^DIK
- Q
- ;
- DELADD N Z,Z0,DA,DIK,X,Y
- S DA(1)=IBIFN
- ;Delete references to proc on rev codes
- S Z=0 F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$G(^(Z,0)) I Z0'="",$P(Z0,U,15)!$S($P(Z0,U,10)=3:$P(Z0,U,11),1:0) S DIE="^DGCR(399,"_DA(1)_",""RC"",",DA=Z,DR=".11///@;.15///@"_$S($P(Z0,U,8):"",1:";.08////1") D ^DIE
- S DIK="^DGCR(399,"_DA(1)_",""CP""," F DA=0:0 S DA=$O(^DGCR(399,DA(1),"CP",DA)) Q:'DA D ^DIK
- S DGRVRCAL=1
- Q
- ;
- DTMES ;Message if procedure date not in date range
- Q:'$D(IBIFN) Q:'$D(^DGCR(399,IBIFN,"U")) S DGNODUU=^("U")
- G:X'<$P(DGNODUU,"^")&(X'>$P(DGNODUU,"^",2)) DTMESQ
- W *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period."
- S Y=$P(DGNODUU,"^") X ^DD("DD")
- W !?3,"Enter a date between ",Y," and " S Y=$P(DGNODUU,"^",2) X ^DD("DD") W Y,!
- K X,Y
- DTMESQ K DGNODUU Q
- ;
- CODHLP ;Display Additional Procedure codes
- N I,J,Y,IBMOD
- I '$O(^DGCR(399,IBIFN,"CP",0)) W !!?5,"No Codes Entered!",! Q
- W ! F I=0:0 S I=$O(^DGCR(399,IBIFN,"CP",I)) Q:'I S Y=$G(^(I,0)) S Z=$$PRCNM^IBCSCH1($P(Y,"^",1),$P(Y,"^",2)) W !?5,$E($P(Z,"^",2),1,33),?40,"- ",$P(Z,"^") D
- . N IBY
- . S IBY=$P(Y,U,2)
- . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1)
- . I IBMOD'="" S IBMOD="/"_IBMOD W IBMOD
- . W ?60,"Date: " S Y=IBY D DT^DIQ
- W !
- ;
- K Z Q
- ;
- DICV I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
- Q
- ;
- DEFDIV(IBIFN) ; Find default division for bill IBIFN
- Q $P($G(^DG(40.8,+$P($G(^DGCR(399,IBIFN,0)),U,22),0)),U)
- ;
- ADDTNL(IBIFN,DA) ;
- N DR,IBOK,X,Y,DIR
- S IBOK=1
- S DR="19T;50.09T;50.08T" D ^DIE ; WCJ;IB*2.0*488 Added Ts
- ;I '($$FT^IBCEF(IBIFN)'=3&($$INPAT^IBCEF(IBIFN))) D ATTACH ; DEM;432 - Prompt for Attachment Control Number.
- I '($$FT^IBCEF(IBIFN)=3&($$INPAT^IBCEF(IBIFN))) D ATTACH ; DEM;432 - Prompt for Attachment Control Number.
- I $D(Y) S IBOK=0 G ADDTNLQ
- ;/Beginning of IB*2.0*488 (vd)
- ;S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA"
- ;S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits,"
- ;S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee."
- ;D ^DIR K DIR
- ;I Y'=1 S IBOK=0 G ADDTNLQ
- ;S DR="W !,"" <<EPSDT>>"";50.07;W !!,"" <<HOSPICE>>"";50.03"
- S DR="50.07T;50.03T" ;WCJ;IB*2.0*488 added Ts
- ;/End of IB*2.0*488 (vd)
- D ^DIE
- W !
- ADDTNLQ Q IBOK
- ;
- XTRA1(Y) ;
- K Y
- Q
- ;
- SPCUNIT(IBIFN,DA) ; return fields for special units if applicable, in DR form
- N IB0,IBCPT,IBDR,IBCT,IBFT,DFN S IBDR=""
- S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),IBFT=$P(IB0,U,19),DFN=$P(IB0,U,2)
- S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IBCPT'["ICPT" G SPCUNTQ
- I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" D SROMIN^IBCU74(IBIFN,DA) G SPCUNTQ ; minutes
- I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPCUNTQ ; miles
- I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$P(IBCPT,U,2))_";" G SPCUNTQ ; hours
- I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)="ANESTHESIA" S IBDR="15;" ; minutes
- SPCUNTQ Q IBDR
- ;
- ATTACH ; DEM;432 - Attachment control number.
- ; Ask if user wants to enter Attachment Control Number.
- N DIR,X,Y,DA,DIE,DR
- S DIR("A")="Enter Attachment Control Number"
- S DIR(0)="Y",DIR("B")="NO"
- D ^DIR
- Q:'Y
- ; User chose to enter Attachment Control Number.
- ; User enters Attachment Control fields.
- S DA(1)=IBIFN,DA=IBPROCP
- S DIE="^DGCR(399,"_DA(1)_",""CP"","
- S DR="71Report Type;72Report Transmission Method;70Attachment Control Number"
- D ^DIE
- Q
- ;
- NOCPROC(IBPROCSV,IBCODE,IBDATE) ; MRD;IB*2.0*516 - Function to determine if procedure is an
- ; "NOC". Returns '1' if "NOC" procedure, otherwise '0'.
- ;
- N IBNOC,IBPROCEX,IBPROCIN,IBPROCNM,IBX,IBLINES,IBSTR,IBEND,IBLN
- S IBNOC=0
- I $G(IBPROCSV)="" G NOCPROCQ
- I $G(IBCODE)="" G NOCPROCQ
- I $G(IBDATE)'?7N G NOCPROCQ
- S IBPROCIN=$P($P(IBPROCSV,U,2),";") ;parsing out the IEN
- I IBPROCIN="" G NOCPROCQ
- ;
- ; If procedure code ends in '99', quit with a '1'.
- ;
- I $E(IBCODE,$L(IBCODE)-1,$L(IBCODE))=99 S IBNOC=1 G NOCPROCQ ;Does code end with 99? If so NOC
- ;
- ; Pull procedure name, then check to see if it contains one of the
- ; specified strings.
- ;
- S IBPROCNM=$$CPT^ICPTCOD(IBCODE,IBDATE)
- S IBPROCNM=$P(IBPROCNM,U,3)
- I IBPROCNM'="",($$NOC(IBPROCNM)) S IBNOC=1 G NOCPROCQ ; Does external match NOC strings? if so NOC
- ;
- ;Does array strings match any of the specified strings
- S IBLINES=$$CPTD^ICPTCOD(IBCODE,"IBINFO",,IBDATE) ;get number of lines/array of lines
- S IBEND=1 S:IBLINES>1 IBEND=IBLINES-1 ;set up counter for loop
- F IBLN=1:1:IBEND D Q:IBNOC=1 ;loop through array so we can check if node values = NOC
- . N IBSTR S IBSTR=$$TM($G(IBINFO(IBLN)))_" "_$$TM($G(IBINFO(IBLN+1)))_" " ;Build strings for NOC comparison
- . S IBNOC=$$NOC(IBSTR) ;is current combination of strings a NOC?
- . Q
- ;
- NOCPROCQ ; Quit out.
- K IBINFO ;killing the array made in CPTD^ICPTCOD
- Q IBNOC
- ;
- NOC(IBTEXT) ; Quit with '1' if IBTEXT contains one of the specified strings.
- ;
- S IBTEXT=$TR(IBTEXT,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- ;
- I IBTEXT["NOT OTHERWISE" Q 1
- I IBTEXT["NOT ELSEWHERE" Q 1
- I IBTEXT["NOT LISTED" Q 1
- I IBTEXT["UNLISTED" Q 1
- I IBTEXT["UNSPECIFIED" Q 1
- I IBTEXT["UNCLASSIFIED" Q 1
- I IBTEXT["NON-SPECIFIED" Q 1
- I IBTEXT["NOS " Q 1
- I IBTEXT["NOS;" Q 1
- I IBTEXT["NOS." Q 1
- I IBTEXT["NOS," Q 1
- I IBTEXT["NOS/" Q 1
- I IBTEXT["(NOS)" Q 1
- I IBTEXT["NOC " Q 1
- I IBTEXT["NOC;" Q 1
- I IBTEXT["NOC." Q 1
- I IBTEXT["NOC," Q 1
- I IBTEXT["NOC/" Q 1
- I IBTEXT["(NOC)" Q 1
- ;
- ; Check if last three charcters are 'NOC' or 'NOS'.
- ;
- S IBTEXT=$E(IBTEXT,$L(IBTEXT)-2,$L(IBTEXT))
- Q 0
- ;
- TM(IBX,IBY) ; Trim Character Y - Default " "
- S IBX=$G(IBX) Q:IBX="" IBX S IBY=$G(IBY) S:'$L(IBY) IBY=" "
- F Q:$E(IBX,1)'=IBY S IBX=$E(IBX,2,$L(IBX))
- F Q:$E(IBX,$L(IBX))'=IBY S IBX=$E(IBX,1,($L(IBX)-1))
- Q IBX
- ;
- ORALCAV(FLD) ;EP;IB*2.0*592
- ; Dictionary Screen function called from Procedures Oral Cavity Fields:
- ; 399.0304.90.01, 399.0304.90.02, 399.0304.90.03, 399.0304.90.04, 399.0304.90.05
- ; Prevents the same Oral Cavity from being selected more than once.
- ; Input: FLD - Field # of the field being checked
- ; DA - IEN of the Service Line Multiple being edited
- ; DA(1) - IEN of the 399 entry being edited
- ; Y - Internal Value of the user response
- ; Returns: 1 - Data input by the user is valid, 0 otherwise
- N NDE,RTN
- S NDE=$G(^DGCR(399,DA(1),"CP",DA,"DEN"))
- S RTN=1 ; Assume Valid Input
- Q:Y="" 1 ; No value entered
- ;
- ; Make sure there are no duplicates
- I FLD=90.01 D Q RTN
- . I $P(NDE,"^",2)=Y S RTN=0 Q
- . I $P(NDE,"^",3)=Y S RTN=0 Q
- . I $P(NDE,"^",4)=Y S RTN=0 Q
- . I $P(NDE,"^",5)=Y S RTN=0 Q
- I FLD=90.02 D Q RTN
- . I $P(NDE,"^",1)=Y S RTN=0 Q
- . I $P(NDE,"^",3)=Y S RTN=0 Q
- . I $P(NDE,"^",4)=Y S RTN=0 Q
- . I $P(NDE,"^",5)=Y S RTN=0 Q
- I FLD=90.03 D Q RTN
- . I $P(NDE,"^",1)=Y S RTN=0 Q
- . I $P(NDE,"^",2)=Y S RTN=0 Q
- . I $P(NDE,"^",4)=Y S RTN=0 Q
- . I $P(NDE,"^",5)=Y S RTN=0 Q
- I FLD=90.04 D Q RTN
- . I $P(NDE,"^",1)=Y S RTN=0 Q
- . I $P(NDE,"^",2)=Y S RTN=0 Q
- . I $P(NDE,"^",3)=Y S RTN=0 Q
- . I $P(NDE,"^",5)=Y S RTN=0 Q
- I FLD=90.05 D Q RTN
- . I $P(NDE,"^",1)=Y S RTN=0 Q
- . I $P(NDE,"^",2)=Y S RTN=0 Q
- . I $P(NDE,"^",3)=Y S RTN=0 Q
- . I $P(NDE,"^",4)=Y S RTN=0 Q
- Q RTN
- ;
- TOOTHS(FLD) ;EP;IB*2.0*592
- ; Dictionary Screen function called from Dental Service Line Tooth fields:
- ; 399,91,.02, 399,91,.03, 399,91,.04, 399,91,.05, 399,91,.06. Prevents the
- ; same Tooth Surface from being selected more than once.
- ; Input: FLD - Field # of the field being checked
- ; DA - Tooth Surface multiple IEN
- ; DA(1) - Service Line multiple IEN
- ; DA(2) - IEN of the 399 entry being edited
- ; Y - Internal Value of the user response
- ; Returns: 1 - Data input by the user is valid, 0 otherwise
- N NDE,RTN
- S NDE=$G(^DGCR(399,DA(2),"CP",DA(1),"DEN1",DA,0))
- S RTN=1 ; Assume Valid Input
- Q:Y="" 1 ; No value entered
- ;
- ; Make sure there are no duplicates
- I FLD=.02 D Q RTN
- . I $P(NDE,"^",3)=Y S RTN=0 Q
- . I $P(NDE,"^",4)=Y S RTN=0 Q
- . I $P(NDE,"^",5)=Y S RTN=0 Q
- . I $P(NDE,"^",6)=Y S RTN=0 Q
- I FLD=.03 D Q RTN
- . I $P(NDE,"^",2)=Y S RTN=0 Q
- . I $P(NDE,"^",4)=Y S RTN=0 Q
- . I $P(NDE,"^",5)=Y S RTN=0 Q
- . I $P(NDE,"^",6)=Y S RTN=0 Q
- I FLD=.04 D Q RTN
- . I $P(NDE,"^",2)=Y S RTN=0 Q
- . I $P(NDE,"^",3)=Y S RTN=0 Q
- . I $P(NDE,"^",5)=Y S RTN=0 Q
- . I $P(NDE,"^",6)=Y S RTN=0 Q
- I FLD=.05 D Q RTN
- . I $P(NDE,"^",2)=Y S RTN=0 Q
- . I $P(NDE,"^",3)=Y S RTN=0 Q
- . I $P(NDE,"^",4)=Y S RTN=0 Q
- . I $P(NDE,"^",6)=Y S RTN=0 Q
- I FLD=.06 D Q RTN
- . I $P(NDE,"^",2)=Y S RTN=0 Q
- . I $P(NDE,"^",3)=Y S RTN=0 Q
- . I $P(NDE,"^",4)=Y S RTN=0 Q
- . I $P(NDE,"^",5)=Y S RTN=0 Q
- Q RTN
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU7 17929 printed Jan 18, 2025@03:22 Page 2
- IBCU7 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
- +1 ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348,371,432,447,488,461,516,522,577,604,616,592,608,714,742**;21-MAR-94;Build 36
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;MAP TO DGCRU7
- +5 ;
- +6 ; This routine is a copy of IBUC7 for testing purposes.
- +7 ;
- CHKX ; -interception of input x from Additional Procedure input
- +1 if X=" "
- GOTO CHKXQ
- +2 IF $$INPAT^IBCEF(DA(1))
- IF '$PIECE($GET(^IBE(350.9,1,1)),"^",15)
- IF X'?1A1.2N
- Begin DoDot:1
- +3 KILL X
- +4 ;Fileman error here will be: The previous error occurred when performing an action specified in a Pre-lookup transform (7.5 node).
- DO EN^DDIOL("Site param does not allow entry of non-PTF procedures")
- End DoDot:1
- GOTO CHKXQ
- +5 if '$DATA(^UTILITY($JOB,"IB"))
- GOTO CHKXQ
- +6 ;S M=($A($E(X,1))-64),S=+$E(X,2) Q:'$G(^UTILITY($J,"IB",M,S)) S X="`"_+^(S)
- +7 SET M=0
- IF X?1A1.2N
- SET N=$GET(^UTILITY($JOB,"IB","B",X))
- SET M=+N
- SET S=+$PIECE(N,U,2)
- SET P=X
- SET S=$GET(^UTILITY($JOB,"IB",M,S))
- IF +S
- SET X="`"_+S
- IF $PIECE(N,U,3)="N"
- SET X=""""_X_""""
- SET $PIECE(^UTILITY($JOB,"IB","B",P),U,3)="Y"
- +8 IF +M
- IF $DATA(DGPROCDT)
- IF DGPROCDT'=$PIECE($GET(^UTILITY($JOB,"IB",M,1)),"^",2)
- SET DGPROCDT=$PIECE(^(1),"^",2)
- WRITE !!,"Procedure Date: "
- SET Y=DGPROCDT
- XECUTE ^DD("DD")
- WRITE Y,!
- CHKXQ QUIT
- +1 ;
- CODMUL ;Date oriented entry of procedure
- DELASK IF $DATA(IBZ20)
- IF IBZ20
- IF IBZ20'=$PIECE(^DGCR(399,IBIFN,0),U,9)
- SET %=2
- WRITE !,"SINCE THE PROCEDURE CODING METHOD HAS BEEN CHANGED, DO YOU WANT TO DELETE ALL",!,"PROCEDURE CODES IN THIS BILL"
- +1 IF $TEST
- DO YN^DICN
- if %=-1
- QUIT
- if %=1
- DO DELADD
- IF %Y?1."?"
- WRITE !!,"If you answer 'Yes', all procedure codes will be DELETED from this bill.",!
- GOTO DELASK
- +2 ;W !,"Procedure Entry:"
- KILL %,%Y,DA,IBZ20,DIK
- +3 ;
- CODDT IF $DATA(IBIFN)
- IF $DATA(^DGCR(399,IBIFN,0))
- IF $PIECE(^(0),U,9)
- SET DIC("V")=$SELECT($PIECE(^(0),U,9)=9:"I +Y(0)=80.1",$PIECE(^(0),U,9)=4!($PIECE(^(0),U,9)=5):"I +Y(0)=81",1:"")
- +1 IF $PIECE($GET(^DGCR(399,IBIFN,0)),"^",5)<3
- SET IBZTYPE=1
- IF $PIECE($GET(^UTILITY($JOB,"IB",1,1)),"^",2)
- SET DGPROCDT=$PIECE(^(1),"^",2)
- DO ASKCOD
- +2 SET X=$$PRCDIV^IBCU71(IBIFN)
- IF +X
- WRITE !!,$PIECE(X,U,2),!
- +3 ; IB*2.0*714
- NEW IBINDTS,Z,Z0
- SET Z=$GET(^DGCR(399,IBIFN,"U"))
- SET IBINDTS=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,28)
- +4 ; ; IB*2.0*714
- SET Z0=$$FMTE^XLFDT($SELECT(IBINDTS>0:IBINDTS,1:$PIECE(Z,U)),"2D")_"-"_$$FMTE^XLFDT($PIECE(Z,U,2),"2D")
- +5 WRITE !,"Select PROCEDURE DATE"_$SELECT($TRANSLATE(Z0,"-")'="":" ("_Z0_")",1:"")_": "
- READ X:DTIME
- if '$TEST!("^"[X)
- GOTO CODQ
- if X["?"
- DO CODHLP
- +6 ; Get procedure date
- SET IBEX=0
- Begin DoDot:1
- +7 IF X=" "
- IF $DATA(DGPROCDT)
- IF DGPROCDT?7N
- SET Y=DGPROCDT
- DO D^DIQ
- WRITE " (",Y,")"
- QUIT
- +8 IF X=" "
- IF +$PIECE($GET(^DGCR(399,IBIFN,"OP",0)),"^",4)
- SET (DGPROCDT,Y)=$ORDER(^DGCR(399,IBIFN,"OP",0))
- DO D^DIQ
- WRITE " (",Y,")"
- QUIT
- +9 SET %DT="EXP"
- SET %DT(0)=-DT
- DO ^%DT
- KILL %DT
- IF Y<1
- SET IBEX=1
- QUIT
- +10 IF '$$OPV2^IBCU41(Y,IBIFN,1)
- SET IBEX=1
- QUIT
- +11 if '$GET(IBZTYPE)
- SET X=$$OPV^IBCU41(Y,IBIFN)
- SET DGPROCDT=Y
- End DoDot:1
- +12 IF 'IBEX
- DO ASKCOD
- if $DATA(DGCPT)
- DO ADDCPT^IBCU71
- +13 KILL IBEX
- +14 GOTO CODDT
- +15 ;
- ASKCOD ;WCJ;2.0*432
- NEW Z,Z0,DA,IBACT,IBQUIT,IBLNPRV,IBCODE,IBPIEN
- +1 ; IB*2.0*447 BI
- NEW IBPOPOUT
- SET IBPOPOUT=0
- +2 KILL DGCPT
- +3 SET DGCPT=0
- SET DGCPTUP=$PIECE($GET(^IBE(350.9,1,1)),"^",19)
- SET DGADDVST=0
- SET IBFT=$PIECE($GET(^DGCR(399,IBIFN,0)),"^",19)
- +4 IF '$DATA(^DGCR(399,IBIFN,"CP",0))
- SET ^DGCR(399,IBIFN,"CP",0)=U_$$GETSPEC^IBEFUNC(399,304)
- +5 ;
- +6 FOR
- SET IBQUIT=0
- Begin DoDot:1
- +7 SET IBPOPOUT=0
- +8 ; restrict code type to PCM
- DO DICV
- +9 SET DIC("A")=" Select PROCEDURE: "
- +10 SET DIC="^DGCR(399,"_IBIFN_",""CP"","
- +11 SET DIC(0)="AEQMNL"
- +12 SET DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCDT)"
- +13 SET DIC("DR")="1///^S X=DGPROCDT"
- +14 SET DA(1)=IBIFN
- SET DLAYGO=399
- +15 WRITE !
- DO ^DIC
- IF Y<1
- SET IBQUIT=1
- QUIT
- +16 SET IBPROCP=+Y
- +17 ;IB*2.0*616, get procedure code, supported by ICR 1995
- SET IBCODE=""
- IF Y["ICPT"
- SET IBPIEN=+$PIECE(Y,U,2)
- SET IBCODE=$PIECE($$CPT^ICPTCOD(IBPIEN),U,2)
- +18 ; If we just added inactive code - it must be deleted.
- +19 ; Active flag
- SET IBACT=0
- +20 IF Y["ICD0"
- SET IBACT=$$ICD0ACT^IBACSV(+$PIECE(Y,U,2),$$BDATE^IBACSV(IBIFN))
- +21 IF Y["ICPT"
- SET IBACT=$$CPTACT^IBACSV(+$PIECE(Y,U,2),DGPROCDT)
- +22 ;Was the procedure just added?
- SET DGCPTNEW=$PIECE(Y,"^",3)
- +23 IF DGCPTNEW
- IF 'IBACT
- DO DELPROC
- QUIT
- +24 IF 'IBACT
- WRITE !,*7,"Warning: Procedure code is inactive on this date",!
- +25 IF DGCPTNEW
- IF $DATA(^UTILITY($JOB,"IB"))
- IF $$INPAT^IBCEF(IBIFN)
- IF Y["ICPT("
- DO DATA^IBCU74(Y,.IBLNPRV)
- +26 SET DGADDVST=$SELECT(DGCPTNEW:1,$DATA(DGADDVST):DGADDVST,1:0)
- +27 NEW IBPRV,IBPRVO,IBPRVN
- +28 ;
- +29 ; Line level provider function by form type.
- +30 ; CMS-1500 (FORM TYPE=2)
- +31 ; RENDERING PROVIDER, REFERRING PROVIDER,
- +32 ; and SUPERVISING PROVIDER.
- +33 ; UB-04 (FORM TYPE=3)
- +34 ; RENDERING PROVIDER, REFERRING PROVIDER,
- +35 ; OPERATING PROVIDER, and OTHER OPERATING
- +36 ; PROVIDER.
- +37 ;
- +38 ; Removed: Call to $$MAINPRV^IBCEU(IBIFN) is for claim
- +39 ; level provider defaults.
- +40 ; 1. For new line level providers we don't need
- +41 ; or want default claim level provider
- +42 ; (requirement).
- +43 ; 2. We don't want to default claim level to
- +44 ; line level provider (requirement).
- +45 ;
- +46 ; DEM;432 - KILL DIC("V") because this was for previous variable pointer use.
- KILL DIC("V")
- +47 ;
- +48 ; DEM;432 - Variable IBPROCSV is variable to preserve value of 'Y', which is procedure code info returned by call to ^DIC.
- NEW IBPROCSV
- +49 ; DEM;432 - Preserve value of Y for after calls to FileMan (Y = procedure code info returned by call to ^DIC).
- SET IBPROCSV=Y
- +50 ;WCJ;IB*2.0*432
- KILL DR
- +51 ;
- +52 ; IB*2.0*461
- IF IBPROCSV["ICD0"
- SET DR=".01"
- SET DIE=DIC
- SET (IBPROCP,DA)=+Y
- DO ^DIE
- if '$DATA(DA)!($DATA(Y))
- QUIT
- KILL DR
- +53 ;
- +54 ;JRA;IB*2.0*608 Prompt user for Certificate of Medical Necessity (CMN) info
- +55 IF $$FT^IBCEF(IBIFN)=2
- IF $$CMNPRMT^IBJPS8(IBIFN,IBPROCP,$PIECE($PIECE(IBPROCSV,U,2),";"))
- DO CMN^IBCU75(IBIFN,IBPROCP)
- +56 ;
- +57 ; WCJ;IB*2.0*742;change the modifier seq number prompt behavior
- +58 ; IB*2.0*447 BI ;WCJ;IB*2.0*742
- IF IBPROCSV["ICPT"
- SET DR=".01"
- SET DIE=DIC
- SET (IBPROCP,DA)=$PIECE(IBPROCSV,U)
- DO ^DIE
- if '$DATA(DA)!($DATA(Y))
- QUIT
- KILL DR
- Begin DoDot:2
- +59 DO EN^IBCU7C(IBPROCP)
- End DoDot:2
- +60 ;
- +61 SET DR=""
- +62 ;
- +63 ; MRD;IB*2.0*516 - Added line level PROCEDURE DESCRIPTION field,
- +64 ; asked only if the procedure is an "NOC".
- +65 ; added IBCODE,DGPROCDT in *604
- IF IBPROCSV["ICPT"
- IF $$NOCPROC(IBPROCSV,IBCODE,DGPROCDT)
- Begin DoDot:2
- +66 ; The line# on the bill/claim.
- SET DA=$PIECE(IBPROCSV,"^")
- +67 ; Field# for PROCEDURE DESCRIPTION
- SET DR=51
- +68 DO ^DIE
- +69 QUIT
- End DoDot:2
- +70 ;
- +71 ; DEM;432 - Call to line level provider user input.
- DO EN^IBCU7B
- +72 ; DEM;432 - Restore value of Y after calls to FileMan
- SET Y=IBPROCSV
- +73 KILL IBPROCSV
- +74 ;WCJ;IB*2.0*432
- KILL DR
- +75 ; IB*2.0*447 BI
- IF IBPOPOUT
- QUIT
- +76 SET DR=""
- IF Y["ICPT"
- SET DR="6;5//"_$$DEFDIV(IBIFN)_";"
- +77 ;JWS;IB*2.0*592 US1108 - Dental
- +78 ;IA# 10018
- +79 SET DR=DR_$SELECT(IBFT=7:"8;",IBFT=2:"8;9;17//NO;",1:"")_3
- SET DIE=DIC
- SET (IBPROCP,DA)=+Y
- DO ^DIE
- if '$DATA(DA)!($EXTRACT($GET(Y))=U)
- QUIT
- +80 ;WCJ;IB*2.0*432
- KILL DR
- +81 ;
- +82 ; MRD;IB*2.0*516 - Allow user to add an NDC and Units. Ask only if
- +83 ; coding system is not ICD and this is not a prescription claim. If
- +84 ; an NDC is entered, prompt for Units.
- +85 IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,9)'=9
- IF '$$RXLINK^IBCSC5C(IBIFN,IBPROCP)
- Begin DoDot:2
- +86 ;JWS;IB*2.0*592 US1108 - Dental
- +87 IF IBFT=7
- QUIT
- +88 KILL DA
- +89 SET DA=IBPROCP
- SET DA(1)=IBIFN
- SET DIE="^DGCR(399,"_IBIFN_",""CP"","
- +90 ; vd/Beginning IB*2*577 - Added the prompt for Unit/Basis of Measurement.
- +91 ; S DR="53NDC NUMBER;I X="""" S Y="""";54//1"
- +92 ;Prompt for NDC, UN & amt.
- SET DR="53NDC NUMBER;I X="""" S Y="""";52R~//UN;54R~QUANTITY//1"
- +93 ; vd/Ending IB*2*577
- +94 DO ^DIE
- +95 QUIT
- End DoDot:2
- +96 ;
- +97 ; DEM;432 - Prompt for Attachment Control Number.
- IF IBFT=3
- if '$$INPAT^IBCEF(IBIFN)
- DO ATTACH
- +98 ; DEM;432 - Add Additional OB Minutes to DR string for call to DIE.
- +99 ; miles/minutes/hours
- SET DR=$$SPCUNIT(IBIFN,IBPROCP)
- if DR["15;"
- SET DR=DR_"74Additional OB Minutes"
- DO ^DIE
- +100 ;JWS;IB*2.0*592 US1108 - Dental
- +101 IF IBFT=2!(IBFT=7)
- Begin DoDot:2
- +102 DO DX^IBCU72(IBIFN,IBPROCP)
- +103 ;JWS;IB*2.0*592 US1108 - Dental
- +104 IF IBFT'=7
- SET X=$$ADDTNL(IBIFN,.DA)
- End DoDot:2
- +105 ;only outpatient bills
- if $$INPAT^IBCEF(IBIFN)
- QUIT
- +106 ;JWS;IB*2.0*592 US1108 - Dental input fields
- +107 IF IBFT=7
- DO ORAL^IBCU72
- +108 ;add procedures to array for download to PCE: dgcpt(assoc clinic,cpt,'provider^first dx^modifiers',cnt)=""
- +109 SET DGPROC=$GET(^DGCR(399,IBIFN,"CP",+DA,0))
- +110 SET X=$PIECE(DGPROC,U,18)_U_+$GET(^IBA(362.3,+$PIECE(DGPROC,U,11),0))_U_$PIECE(DGPROC,U,15)
- +111 IF 'DGCPTNEW
- IF $PIECE(DGPROC,"^",7)=""
- SET DGCPTNEW=2
- +112 IF DGCPTUP
- IF DGCPTNEW
- SET DGCPT=DGCPT+1
- IF $PIECE(DGPROC,"^",7)
- SET DGCPT($PIECE(DGPROC,"^",7),+DGPROC,X,DGCPT)=""
- +113 ; add visit date to bill
- +114 IF DGADDVST
- SET (X,DINUM)=DGPROCDT
- DO VFILE1^IBCOPV1
- KILL DINUM,X,DGNOADD,DGADDVST
- End DoDot:1
- if IBQUIT
- QUIT
- +115 ; Delete modifiers with only a sequence #, no code
- +116 SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399,IBIFN,"CP",Z))
- if 'Z
- QUIT
- SET Z0=0
- FOR
- SET Z0=$ORDER(^DGCR(399,IBIFN,"CP",Z,"MOD",Z0))
- if 'Z0
- QUIT
- IF $PIECE($GET(^(Z0,0)),U,2)=""
- SET DA(2)=IBIFN
- SET DA(1)=Z
- SET DA=Z0
- SET DIK="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD"","
- DO ^DIK
- +117 QUIT
- CODQ KILL %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO
- +1 KILL IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW
- +2 QUIT
- +3 ;
- DELPROC ; Remove the selected procedure, because of inactive status (cancel selection)
- +1 WRITE !!,*7,"The Procedure code is inactive on ",$$DAT1^IBOUTL(DGPROCDT),"."
- +2 WRITE !,"Please select another Procedure."
- +3 SET DA(1)=IBIFN
- SET DA=+Y
- SET DIK="^DGCR(399,"_IBIFN_",""CP"","
- +4 DO ^DIK
- +5 QUIT
- +6 ;
- DELADD NEW Z,Z0,DA,DIK,X,Y
- +1 SET DA(1)=IBIFN
- +2 ;Delete references to proc on rev codes
- +3 SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399,IBIFN,"RC",Z))
- if 'Z
- QUIT
- SET Z0=$GET(^(Z,0))
- IF Z0'=""
- IF $PIECE(Z0,U,15)!$SELECT($PIECE(Z0,U,10)=3:$PIECE(Z0,U,11),1:0)
- SET DIE="^DGCR(399,"_DA(1)_",""RC"","
- SET DA=Z
- SET DR=".11///@;.15///@"_$SELECT($PIECE(Z0,U,8):"",1:";.08////1")
- DO ^DIE
- +4 SET DIK="^DGCR(399,"_DA(1)_",""CP"","
- FOR DA=0:0
- SET DA=$ORDER(^DGCR(399,DA(1),"CP",DA))
- if 'DA
- QUIT
- DO ^DIK
- +5 SET DGRVRCAL=1
- +6 QUIT
- +7 ;
- DTMES ;Message if procedure date not in date range
- +1 if '$DATA(IBIFN)
- QUIT
- if '$DATA(^DGCR(399,IBIFN,"U"))
- QUIT
- SET DGNODUU=^("U")
- +2 if X'<$PIECE(DGNODUU,"^")&(X'>$PIECE(DGNODUU,"^",2))
- GOTO DTMESQ
- +3 WRITE *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period."
- +4 SET Y=$PIECE(DGNODUU,"^")
- XECUTE ^DD("DD")
- +5 WRITE !?3,"Enter a date between ",Y," and "
- SET Y=$PIECE(DGNODUU,"^",2)
- XECUTE ^DD("DD")
- WRITE Y,!
- +6 KILL X,Y
- DTMESQ KILL DGNODUU
- QUIT
- +1 ;
- CODHLP ;Display Additional Procedure codes
- +1 NEW I,J,Y,IBMOD
- +2 IF '$ORDER(^DGCR(399,IBIFN,"CP",0))
- WRITE !!?5,"No Codes Entered!",!
- QUIT
- +3 WRITE !
- FOR I=0:0
- SET I=$ORDER(^DGCR(399,IBIFN,"CP",I))
- if 'I
- QUIT
- SET Y=$GET(^(I,0))
- SET Z=$$PRCNM^IBCSCH1($PIECE(Y,"^",1),$PIECE(Y,"^",2))
- WRITE !?5,$EXTRACT($PIECE(Z,"^",2),1,33),?40,"- ",$PIECE(Z,"^")
- Begin DoDot:1
- +4 NEW IBY
- +5 SET IBY=$PIECE(Y,U,2)
- +6 SET IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1)
- +7 IF IBMOD'=""
- SET IBMOD="/"_IBMOD
- WRITE IBMOD
- +8 WRITE ?60,"Date: "
- SET Y=IBY
- DO DT^DIQ
- End DoDot:1
- +9 WRITE !
- +10 ;
- +11 KILL Z
- QUIT
- +12 ;
- DICV IF $DATA(IBIFN)
- IF $DATA(^DGCR(399,IBIFN,0))
- IF $PIECE(^(0),U,9)
- SET DIC("V")=$SELECT($PIECE(^(0),U,9)=9:"I +Y(0)=80.1",$PIECE(^(0),U,9)=4!($PIECE(^(0),U,9)=5):"I +Y(0)=81",1:"")
- +1 QUIT
- +2 ;
- DEFDIV(IBIFN) ; Find default division for bill IBIFN
- +1 QUIT $PIECE($GET(^DG(40.8,+$PIECE($GET(^DGCR(399,IBIFN,0)),U,22),0)),U)
- +2 ;
- ADDTNL(IBIFN,DA) ;
- +1 NEW DR,IBOK,X,Y,DIR
- +2 SET IBOK=1
- +3 ; WCJ;IB*2.0*488 Added Ts
- SET DR="19T;50.09T;50.08T"
- DO ^DIE
- +4 ;I '($$FT^IBCEF(IBIFN)'=3&($$INPAT^IBCEF(IBIFN))) D ATTACH ; DEM;432 - Prompt for Attachment Control Number.
- +5 ; DEM;432 - Prompt for Attachment Control Number.
- IF '($$FT^IBCEF(IBIFN)=3&($$INPAT^IBCEF(IBIFN)))
- DO ATTACH
- +6 IF $DATA(Y)
- SET IBOK=0
- GOTO ADDTNLQ
- +7 ;/Beginning of IB*2.0*488 (vd)
- +8 ;S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA"
- +9 ;S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits,"
- +10 ;S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee."
- +11 ;D ^DIR K DIR
- +12 ;I Y'=1 S IBOK=0 G ADDTNLQ
- +13 ;S DR="W !,"" <<EPSDT>>"";50.07;W !!,"" <<HOSPICE>>"";50.03"
- +14 ;WCJ;IB*2.0*488 added Ts
- SET DR="50.07T;50.03T"
- +15 ;/End of IB*2.0*488 (vd)
- +16 DO ^DIE
- +17 WRITE !
- ADDTNLQ QUIT IBOK
- +1 ;
- XTRA1(Y) ;
- +1 KILL Y
- +2 QUIT
- +3 ;
- SPCUNIT(IBIFN,DA) ; return fields for special units if applicable, in DR form
- +1 NEW IB0,IBCPT,IBDR,IBCT,IBFT,DFN
- SET IBDR=""
- +2 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
- SET IBCT=$PIECE(IB0,U,27)
- SET IBFT=$PIECE(IB0,U,19)
- SET DFN=$PIECE(IB0,U,2)
- +3 SET IBCPT=$GET(^DGCR(399,+$GET(IBIFN),"CP",+$GET(DA),0))
- IF IBCPT'["ICPT"
- GOTO SPCUNTQ
- +4 ; minutes
- IF +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT)
- SET IBDR="15;"
- DO SROMIN^IBCU74(IBIFN,DA)
- GOTO SPCUNTQ
- +5 ; miles
- IF +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT)
- SET IBDR="21;"
- GOTO SPCUNTQ
- +6 ; hours
- IF +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT)
- SET IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$PIECE(IBCPT,U,2))_";"
- GOTO SPCUNTQ
- +7 ; minutes
- IF +IBFT=2
- IF $PIECE($GET(^IBE(353.2,+$PIECE(IBCPT,U,10),0)),U,2)="ANESTHESIA"
- SET IBDR="15;"
- SPCUNTQ QUIT IBDR
- +1 ;
- ATTACH ; DEM;432 - Attachment control number.
- +1 ; Ask if user wants to enter Attachment Control Number.
- +2 NEW DIR,X,Y,DA,DIE,DR
- +3 SET DIR("A")="Enter Attachment Control Number"
- +4 SET DIR(0)="Y"
- SET DIR("B")="NO"
- +5 DO ^DIR
- +6 if 'Y
- QUIT
- +7 ; User chose to enter Attachment Control Number.
- +8 ; User enters Attachment Control fields.
- +9 SET DA(1)=IBIFN
- SET DA=IBPROCP
- +10 SET DIE="^DGCR(399,"_DA(1)_",""CP"","
- +11 SET DR="71Report Type;72Report Transmission Method;70Attachment Control Number"
- +12 DO ^DIE
- +13 QUIT
- +14 ;
- NOCPROC(IBPROCSV,IBCODE,IBDATE) ; MRD;IB*2.0*516 - Function to determine if procedure is an
- +1 ; "NOC". Returns '1' if "NOC" procedure, otherwise '0'.
- +2 ;
- +3 NEW IBNOC,IBPROCEX,IBPROCIN,IBPROCNM,IBX,IBLINES,IBSTR,IBEND,IBLN
- +4 SET IBNOC=0
- +5 IF $GET(IBPROCSV)=""
- GOTO NOCPROCQ
- +6 IF $GET(IBCODE)=""
- GOTO NOCPROCQ
- +7 IF $GET(IBDATE)'?7N
- GOTO NOCPROCQ
- +8 ;parsing out the IEN
- SET IBPROCIN=$PIECE($PIECE(IBPROCSV,U,2),";")
- +9 IF IBPROCIN=""
- GOTO NOCPROCQ
- +10 ;
- +11 ; If procedure code ends in '99', quit with a '1'.
- +12 ;
- +13 ;Does code end with 99? If so NOC
- IF $EXTRACT(IBCODE,$LENGTH(IBCODE)-1,$LENGTH(IBCODE))=99
- SET IBNOC=1
- GOTO NOCPROCQ
- +14 ;
- +15 ; Pull procedure name, then check to see if it contains one of the
- +16 ; specified strings.
- +17 ;
- +18 SET IBPROCNM=$$CPT^ICPTCOD(IBCODE,IBDATE)
- +19 SET IBPROCNM=$PIECE(IBPROCNM,U,3)
- +20 ; Does external match NOC strings? if so NOC
- IF IBPROCNM'=""
- IF ($$NOC(IBPROCNM))
- SET IBNOC=1
- GOTO NOCPROCQ
- +21 ;
- +22 ;Does array strings match any of the specified strings
- +23 ;get number of lines/array of lines
- SET IBLINES=$$CPTD^ICPTCOD(IBCODE,"IBINFO",,IBDATE)
- +24 ;set up counter for loop
- SET IBEND=1
- if IBLINES>1
- SET IBEND=IBLINES-1
- +25 ;loop through array so we can check if node values = NOC
FOR IBLN=1:1:IBEND
Begin DoDot:1
+26 ;Build strings for NOC comparison
NEW IBSTR
SET IBSTR=$$TM($GET(IBINFO(IBLN)))_" "_$$TM($GET(IBINFO(IBLN+1)))_" "
+27 ;is current combination of strings a NOC?
SET IBNOC=$$NOC(IBSTR)
+28 QUIT
End DoDot:1
if IBNOC=1
QUIT
+29 ;
NOCPROCQ ; Quit out.
+1 ;killing the array made in CPTD^ICPTCOD
KILL IBINFO
+2 QUIT IBNOC
+3 ;
NOC(IBTEXT) ; Quit with '1' if IBTEXT contains one of the specified strings.
+1 ;
+2 SET IBTEXT=$TRANSLATE(IBTEXT,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 ;
+4 IF IBTEXT["NOT OTHERWISE"
QUIT 1
+5 IF IBTEXT["NOT ELSEWHERE"
QUIT 1
+6 IF IBTEXT["NOT LISTED"
QUIT 1
+7 IF IBTEXT["UNLISTED"
QUIT 1
+8 IF IBTEXT["UNSPECIFIED"
QUIT 1
+9 IF IBTEXT["UNCLASSIFIED"
QUIT 1
+10 IF IBTEXT["NON-SPECIFIED"
QUIT 1
+11 IF IBTEXT["NOS "
QUIT 1
+12 IF IBTEXT["NOS;"
QUIT 1
+13 IF IBTEXT["NOS."
QUIT 1
+14 IF IBTEXT["NOS,"
QUIT 1
+15 IF IBTEXT["NOS/"
QUIT 1
+16 IF IBTEXT["(NOS)"
QUIT 1
+17 IF IBTEXT["NOC "
QUIT 1
+18 IF IBTEXT["NOC;"
QUIT 1
+19 IF IBTEXT["NOC."
QUIT 1
+20 IF IBTEXT["NOC,"
QUIT 1
+21 IF IBTEXT["NOC/"
QUIT 1
+22 IF IBTEXT["(NOC)"
QUIT 1
+23 ;
+24 ; Check if last three charcters are 'NOC' or 'NOS'.
+25 ;
+26 SET IBTEXT=$EXTRACT(IBTEXT,$LENGTH(IBTEXT)-2,$LENGTH(IBTEXT))
+27 QUIT 0
+28 ;
TM(IBX,IBY) ; Trim Character Y - Default " "
+1 SET IBX=$GET(IBX)
if IBX=""
QUIT IBX
SET IBY=$GET(IBY)
if '$LENGTH(IBY)
SET IBY=" "
+2 FOR
if $EXTRACT(IBX,1)'=IBY
QUIT
SET IBX=$EXTRACT(IBX,2,$LENGTH(IBX))
+3 FOR
if $EXTRACT(IBX,$LENGTH(IBX))'=IBY
QUIT
SET IBX=$EXTRACT(IBX,1,($LENGTH(IBX)-1))
+4 QUIT IBX
+5 ;
ORALCAV(FLD) ;EP;IB*2.0*592
+1 ; Dictionary Screen function called from Procedures Oral Cavity Fields:
+2 ; 399.0304.90.01, 399.0304.90.02, 399.0304.90.03, 399.0304.90.04, 399.0304.90.05
+3 ; Prevents the same Oral Cavity from being selected more than once.
+4 ; Input: FLD - Field # of the field being checked
+5 ; DA - IEN of the Service Line Multiple being edited
+6 ; DA(1) - IEN of the 399 entry being edited
+7 ; Y - Internal Value of the user response
+8 ; Returns: 1 - Data input by the user is valid, 0 otherwise
+9 NEW NDE,RTN
+10 SET NDE=$GET(^DGCR(399,DA(1),"CP",DA,"DEN"))
+11 ; Assume Valid Input
SET RTN=1
+12 ; No value entered
if Y=""
QUIT 1
+13 ;
+14 ; Make sure there are no duplicates
+15 IF FLD=90.01
Begin DoDot:1
+16 IF $PIECE(NDE,"^",2)=Y
SET RTN=0
QUIT
+17 IF $PIECE(NDE,"^",3)=Y
SET RTN=0
QUIT
+18 IF $PIECE(NDE,"^",4)=Y
SET RTN=0
QUIT
+19 IF $PIECE(NDE,"^",5)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+20 IF FLD=90.02
Begin DoDot:1
+21 IF $PIECE(NDE,"^",1)=Y
SET RTN=0
QUIT
+22 IF $PIECE(NDE,"^",3)=Y
SET RTN=0
QUIT
+23 IF $PIECE(NDE,"^",4)=Y
SET RTN=0
QUIT
+24 IF $PIECE(NDE,"^",5)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+25 IF FLD=90.03
Begin DoDot:1
+26 IF $PIECE(NDE,"^",1)=Y
SET RTN=0
QUIT
+27 IF $PIECE(NDE,"^",2)=Y
SET RTN=0
QUIT
+28 IF $PIECE(NDE,"^",4)=Y
SET RTN=0
QUIT
+29 IF $PIECE(NDE,"^",5)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+30 IF FLD=90.04
Begin DoDot:1
+31 IF $PIECE(NDE,"^",1)=Y
SET RTN=0
QUIT
+32 IF $PIECE(NDE,"^",2)=Y
SET RTN=0
QUIT
+33 IF $PIECE(NDE,"^",3)=Y
SET RTN=0
QUIT
+34 IF $PIECE(NDE,"^",5)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+35 IF FLD=90.05
Begin DoDot:1
+36 IF $PIECE(NDE,"^",1)=Y
SET RTN=0
QUIT
+37 IF $PIECE(NDE,"^",2)=Y
SET RTN=0
QUIT
+38 IF $PIECE(NDE,"^",3)=Y
SET RTN=0
QUIT
+39 IF $PIECE(NDE,"^",4)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+40 QUIT RTN
+41 ;
TOOTHS(FLD) ;EP;IB*2.0*592
+1 ; Dictionary Screen function called from Dental Service Line Tooth fields:
+2 ; 399,91,.02, 399,91,.03, 399,91,.04, 399,91,.05, 399,91,.06. Prevents the
+3 ; same Tooth Surface from being selected more than once.
+4 ; Input: FLD - Field # of the field being checked
+5 ; DA - Tooth Surface multiple IEN
+6 ; DA(1) - Service Line multiple IEN
+7 ; DA(2) - IEN of the 399 entry being edited
+8 ; Y - Internal Value of the user response
+9 ; Returns: 1 - Data input by the user is valid, 0 otherwise
+10 NEW NDE,RTN
+11 SET NDE=$GET(^DGCR(399,DA(2),"CP",DA(1),"DEN1",DA,0))
+12 ; Assume Valid Input
SET RTN=1
+13 ; No value entered
if Y=""
QUIT 1
+14 ;
+15 ; Make sure there are no duplicates
+16 IF FLD=.02
Begin DoDot:1
+17 IF $PIECE(NDE,"^",3)=Y
SET RTN=0
QUIT
+18 IF $PIECE(NDE,"^",4)=Y
SET RTN=0
QUIT
+19 IF $PIECE(NDE,"^",5)=Y
SET RTN=0
QUIT
+20 IF $PIECE(NDE,"^",6)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+21 IF FLD=.03
Begin DoDot:1
+22 IF $PIECE(NDE,"^",2)=Y
SET RTN=0
QUIT
+23 IF $PIECE(NDE,"^",4)=Y
SET RTN=0
QUIT
+24 IF $PIECE(NDE,"^",5)=Y
SET RTN=0
QUIT
+25 IF $PIECE(NDE,"^",6)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+26 IF FLD=.04
Begin DoDot:1
+27 IF $PIECE(NDE,"^",2)=Y
SET RTN=0
QUIT
+28 IF $PIECE(NDE,"^",3)=Y
SET RTN=0
QUIT
+29 IF $PIECE(NDE,"^",5)=Y
SET RTN=0
QUIT
+30 IF $PIECE(NDE,"^",6)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+31 IF FLD=.05
Begin DoDot:1
+32 IF $PIECE(NDE,"^",2)=Y
SET RTN=0
QUIT
+33 IF $PIECE(NDE,"^",3)=Y
SET RTN=0
QUIT
+34 IF $PIECE(NDE,"^",4)=Y
SET RTN=0
QUIT
+35 IF $PIECE(NDE,"^",6)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+36 IF FLD=.06
Begin DoDot:1
+37 IF $PIECE(NDE,"^",2)=Y
SET RTN=0
QUIT
+38 IF $PIECE(NDE,"^",3)=Y
SET RTN=0
QUIT
+39 IF $PIECE(NDE,"^",4)=Y
SET RTN=0
QUIT
+40 IF $PIECE(NDE,"^",5)=Y
SET RTN=0
QUIT
End DoDot:1
QUIT RTN
+41 QUIT RTN
+42 ;