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

IBCU7.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;MAP TO DGCRU7
  1. ;
  1. ; This routine is a copy of IBUC7 for testing purposes.
  1. ;
  1. CHKX ; -interception of input x from Additional Procedure input
  1. G:X=" " CHKXQ
  1. I $$INPAT^IBCEF(DA(1)),'$P($G(^IBE(350.9,1,1)),"^",15),X'?1A1.2N D G CHKXQ
  1. . K X
  1. . 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).
  1. G:'$D(^UTILITY($J,"IB")) CHKXQ
  1. ;S M=($A($E(X,1))-64),S=+$E(X,2) Q:'$G(^UTILITY($J,"IB",M,S)) S X="`"_+^(S)
  1. 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"
  1. 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,!
  1. CHKXQ Q
  1. ;
  1. CODMUL ;Date oriented entry of procedure
  1. 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"
  1. 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
  1. K %,%Y,DA,IBZ20,DIK ;W !,"Procedure Entry:"
  1. ;
  1. 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:"")
  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
  1. S X=$$PRCDIV^IBCU71(IBIFN) I +X W !!,$P(X,U,2),!
  1. N IBINDTS,Z,Z0 S Z=$G(^DGCR(399,IBIFN,"U")),IBINDTS=+$P($G(^DGCR(399,IBIFN,0)),U,28) ; IB*2.0*714
  1. S Z0=$$FMTE^XLFDT($S(IBINDTS>0:IBINDTS,1:$P(Z,U)),"2D")_"-"_$$FMTE^XLFDT($P(Z,U,2),"2D") ; ; IB*2.0*714
  1. W !,"Select PROCEDURE DATE"_$S($TR(Z0,"-")'="":" ("_Z0_")",1:"")_": " R X:DTIME G:'$T!("^"[X) CODQ D:X["?" CODHLP
  1. S IBEX=0 D ; Get procedure date
  1. . I X=" ",$D(DGPROCDT),DGPROCDT?7N S Y=DGPROCDT D D^DIQ W " (",Y,")" Q
  1. . 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
  1. . S %DT="EXP",%DT(0)=-DT D ^%DT K %DT I Y<1 S IBEX=1 Q
  1. . I '$$OPV2^IBCU41(Y,IBIFN,1) S IBEX=1 Q
  1. . S:'$G(IBZTYPE) X=$$OPV^IBCU41(Y,IBIFN) S DGPROCDT=Y
  1. I 'IBEX D ASKCOD,ADDCPT^IBCU71:$D(DGCPT)
  1. K IBEX
  1. G CODDT
  1. ;
  1. ASKCOD N Z,Z0,DA,IBACT,IBQUIT,IBLNPRV,IBCODE,IBPIEN ;WCJ;2.0*432
  1. N IBPOPOUT S IBPOPOUT=0 ; IB*2.0*447 BI
  1. K DGCPT
  1. S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^",19),DGADDVST=0,IBFT=$P($G(^DGCR(399,IBIFN,0)),"^",19)
  1. I '$D(^DGCR(399,IBIFN,"CP",0)) S ^DGCR(399,IBIFN,"CP",0)=U_$$GETSPEC^IBEFUNC(399,304)
  1. ;
  1. F S IBQUIT=0 D Q:IBQUIT
  1. . S IBPOPOUT=0
  1. . D DICV ; restrict code type to PCM
  1. . S DIC("A")=" Select PROCEDURE: "
  1. . S DIC="^DGCR(399,"_IBIFN_",""CP"","
  1. . S DIC(0)="AEQMNL"
  1. . S DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCDT)"
  1. . S DIC("DR")="1///^S X=DGPROCDT"
  1. . S DA(1)=IBIFN,DLAYGO=399
  1. . W ! D ^DIC I Y<1 S IBQUIT=1 Q
  1. . S IBPROCP=+Y
  1. . 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
  1. . ; If we just added inactive code - it must be deleted.
  1. . S IBACT=0 ; Active flag
  1. . I Y["ICD0" S IBACT=$$ICD0ACT^IBACSV(+$P(Y,U,2),$$BDATE^IBACSV(IBIFN))
  1. . I Y["ICPT" S IBACT=$$CPTACT^IBACSV(+$P(Y,U,2),DGPROCDT)
  1. . S DGCPTNEW=$P(Y,"^",3) ;Was the procedure just added?
  1. . I DGCPTNEW,'IBACT D DELPROC Q
  1. . I 'IBACT W !,*7,"Warning: Procedure code is inactive on this date",!
  1. . I DGCPTNEW,$D(^UTILITY($J,"IB")),$$INPAT^IBCEF(IBIFN),Y["ICPT(" D DATA^IBCU74(Y,.IBLNPRV)
  1. . S DGADDVST=$S(DGCPTNEW:1,$D(DGADDVST):DGADDVST,1:0)
  1. . N IBPRV,IBPRVO,IBPRVN
  1. . ;
  1. . ; Line level provider function by form type.
  1. . ; CMS-1500 (FORM TYPE=2)
  1. . ; RENDERING PROVIDER, REFERRING PROVIDER,
  1. . ; and SUPERVISING PROVIDER.
  1. . ; UB-04 (FORM TYPE=3)
  1. . ; RENDERING PROVIDER, REFERRING PROVIDER,
  1. . ; OPERATING PROVIDER, and OTHER OPERATING
  1. . ; PROVIDER.
  1. . ;
  1. . ; Removed: Call to $$MAINPRV^IBCEU(IBIFN) is for claim
  1. . ; level provider defaults.
  1. . ; 1. For new line level providers we don't need
  1. . ; or want default claim level provider
  1. . ; (requirement).
  1. . ; 2. We don't want to default claim level to
  1. . ; line level provider (requirement).
  1. . ;
  1. . K DIC("V") ; DEM;432 - KILL DIC("V") because this was for previous variable pointer use.
  1. . ;
  1. . N IBPROCSV ; DEM;432 - Variable IBPROCSV is variable to preserve value of 'Y', which is procedure code info returned by call to ^DIC.
  1. . S IBPROCSV=Y ; DEM;432 - Preserve value of Y for after calls to FileMan (Y = procedure code info returned by call to ^DIC).
  1. . K DR ;WCJ;IB*2.0*432
  1. . ;
  1. . I IBPROCSV["ICD0" S DR=".01",DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($D(Y)) K DR ; IB*2.0*461
  1. . ;
  1. . ;JRA;IB*2.0*608 Prompt user for Certificate of Medical Necessity (CMN) info
  1. . I $$FT^IBCEF(IBIFN)=2,$$CMNPRMT^IBJPS8(IBIFN,IBPROCP,$P($P(IBPROCSV,U,2),";")) D CMN^IBCU75(IBIFN,IBPROCP)
  1. . ;
  1. . ; WCJ;IB*2.0*742;change the modifier seq number prompt behavior
  1. . 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
  1. .. D EN^IBCU7C(IBPROCP)
  1. . ;
  1. . S DR=""
  1. . ;
  1. . ; MRD;IB*2.0*516 - Added line level PROCEDURE DESCRIPTION field,
  1. . ; asked only if the procedure is an "NOC".
  1. . I IBPROCSV["ICPT",$$NOCPROC(IBPROCSV,IBCODE,DGPROCDT) D ; added IBCODE,DGPROCDT in *604
  1. . . S DA=$P(IBPROCSV,"^") ; The line# on the bill/claim.
  1. . . S DR=51 ; Field# for PROCEDURE DESCRIPTION
  1. . . D ^DIE
  1. . . Q
  1. . ;
  1. . D EN^IBCU7B ; DEM;432 - Call to line level provider user input.
  1. . S Y=IBPROCSV ; DEM;432 - Restore value of Y after calls to FileMan
  1. . K IBPROCSV
  1. . K DR ;WCJ;IB*2.0*432
  1. . I IBPOPOUT Q ; IB*2.0*447 BI
  1. . S DR="" I Y["ICPT" S DR="6;5//"_$$DEFDIV(IBIFN)_";"
  1. . ;JWS;IB*2.0*592 US1108 - Dental
  1. . ;IA# 10018
  1. . 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)
  1. . K DR ;WCJ;IB*2.0*432
  1. . ;
  1. . ; MRD;IB*2.0*516 - Allow user to add an NDC and Units. Ask only if
  1. . ; coding system is not ICD and this is not a prescription claim. If
  1. . ; an NDC is entered, prompt for Units.
  1. . I $P($G(^DGCR(399,IBIFN,0)),U,9)'=9,'$$RXLINK^IBCSC5C(IBIFN,IBPROCP) D
  1. . . ;JWS;IB*2.0*592 US1108 - Dental
  1. . . I IBFT=7 Q
  1. . . K DA
  1. . . S DA=IBPROCP,DA(1)=IBIFN,DIE="^DGCR(399,"_IBIFN_",""CP"","
  1. . . ; vd/Beginning IB*2*577 - Added the prompt for Unit/Basis of Measurement.
  1. . . ; S DR="53NDC NUMBER;I X="""" S Y="""";54//1"
  1. . . S DR="53NDC NUMBER;I X="""" S Y="""";52R~//UN;54R~QUANTITY//1" ;Prompt for NDC, UN & amt.
  1. . . ; vd/Ending IB*2*577
  1. . . D ^DIE
  1. . . Q
  1. . ;
  1. . I IBFT=3 D:'$$INPAT^IBCEF(IBIFN) ATTACH ; DEM;432 - Prompt for Attachment Control Number.
  1. . ; DEM;432 - Add Additional OB Minutes to DR string for call to DIE.
  1. . S DR=$$SPCUNIT(IBIFN,IBPROCP) S:DR["15;" DR=DR_"74Additional OB Minutes" D ^DIE ; miles/minutes/hours
  1. . ;JWS;IB*2.0*592 US1108 - Dental
  1. . I IBFT=2!(IBFT=7) D
  1. .. D DX^IBCU72(IBIFN,IBPROCP)
  1. .. ;JWS;IB*2.0*592 US1108 - Dental
  1. .. I IBFT'=7 S X=$$ADDTNL(IBIFN,.DA)
  1. . Q:$$INPAT^IBCEF(IBIFN) ;only outpatient bills
  1. . ;JWS;IB*2.0*592 US1108 - Dental input fields
  1. . I IBFT=7 D ORAL^IBCU72
  1. . ;add procedures to array for download to PCE: dgcpt(assoc clinic,cpt,'provider^first dx^modifiers',cnt)=""
  1. . S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0))
  1. . S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,11),0))_U_$P(DGPROC,U,15)
  1. . I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2
  1. . I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^",7) S DGCPT($P(DGPROC,"^",7),+DGPROC,X,DGCPT)=""
  1. . ; add visit date to bill
  1. . I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K DINUM,X,DGNOADD,DGADDVST
  1. ; Delete modifiers with only a sequence #, no code
  1. 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
  1. Q
  1. CODQ K %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO
  1. K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW
  1. Q
  1. ;
  1. DELPROC ; Remove the selected procedure, because of inactive status (cancel selection)
  1. W !!,*7,"The Procedure code is inactive on ",$$DAT1^IBOUTL(DGPROCDT),"."
  1. W !,"Please select another Procedure."
  1. S DA(1)=IBIFN,DA=+Y,DIK="^DGCR(399,"_IBIFN_",""CP"","
  1. D ^DIK
  1. Q
  1. ;
  1. DELADD N Z,Z0,DA,DIK,X,Y
  1. S DA(1)=IBIFN
  1. ;Delete references to proc on rev codes
  1. 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
  1. S DIK="^DGCR(399,"_DA(1)_",""CP""," F DA=0:0 S DA=$O(^DGCR(399,DA(1),"CP",DA)) Q:'DA D ^DIK
  1. S DGRVRCAL=1
  1. Q
  1. ;
  1. DTMES ;Message if procedure date not in date range
  1. Q:'$D(IBIFN) Q:'$D(^DGCR(399,IBIFN,"U")) S DGNODUU=^("U")
  1. G:X'<$P(DGNODUU,"^")&(X'>$P(DGNODUU,"^",2)) DTMESQ
  1. W *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period."
  1. S Y=$P(DGNODUU,"^") X ^DD("DD")
  1. W !?3,"Enter a date between ",Y," and " S Y=$P(DGNODUU,"^",2) X ^DD("DD") W Y,!
  1. K X,Y
  1. DTMESQ K DGNODUU Q
  1. ;
  1. CODHLP ;Display Additional Procedure codes
  1. N I,J,Y,IBMOD
  1. I '$O(^DGCR(399,IBIFN,"CP",0)) W !!?5,"No Codes Entered!",! Q
  1. 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
  1. . N IBY
  1. . S IBY=$P(Y,U,2)
  1. . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1)
  1. . I IBMOD'="" S IBMOD="/"_IBMOD W IBMOD
  1. . W ?60,"Date: " S Y=IBY D DT^DIQ
  1. W !
  1. ;
  1. K Z Q
  1. ;
  1. 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:"")
  1. Q
  1. ;
  1. DEFDIV(IBIFN) ; Find default division for bill IBIFN
  1. Q $P($G(^DG(40.8,+$P($G(^DGCR(399,IBIFN,0)),U,22),0)),U)
  1. ;
  1. ADDTNL(IBIFN,DA) ;
  1. N DR,IBOK,X,Y,DIR
  1. S IBOK=1
  1. S DR="19T;50.09T;50.08T" D ^DIE ; WCJ;IB*2.0*488 Added Ts
  1. ;I '($$FT^IBCEF(IBIFN)'=3&($$INPAT^IBCEF(IBIFN))) D ATTACH ; DEM;432 - Prompt for Attachment Control Number.
  1. I '($$FT^IBCEF(IBIFN)=3&($$INPAT^IBCEF(IBIFN))) D ATTACH ; DEM;432 - Prompt for Attachment Control Number.
  1. I $D(Y) S IBOK=0 G ADDTNLQ
  1. ;/Beginning of IB*2.0*488 (vd)
  1. ;S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA"
  1. ;S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits,"
  1. ;S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee."
  1. ;D ^DIR K DIR
  1. ;I Y'=1 S IBOK=0 G ADDTNLQ
  1. ;S DR="W !,"" <<EPSDT>>"";50.07;W !!,"" <<HOSPICE>>"";50.03"
  1. S DR="50.07T;50.03T" ;WCJ;IB*2.0*488 added Ts
  1. ;/End of IB*2.0*488 (vd)
  1. D ^DIE
  1. W !
  1. ADDTNLQ Q IBOK
  1. ;
  1. XTRA1(Y) ;
  1. K Y
  1. Q
  1. ;
  1. SPCUNIT(IBIFN,DA) ; return fields for special units if applicable, in DR form
  1. N IB0,IBCPT,IBDR,IBCT,IBFT,DFN S IBDR=""
  1. S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),IBFT=$P(IB0,U,19),DFN=$P(IB0,U,2)
  1. S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IBCPT'["ICPT" G SPCUNTQ
  1. I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" D SROMIN^IBCU74(IBIFN,DA) G SPCUNTQ ; minutes
  1. I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPCUNTQ ; miles
  1. I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$P(IBCPT,U,2))_";" G SPCUNTQ ; hours
  1. I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)="ANESTHESIA" S IBDR="15;" ; minutes
  1. SPCUNTQ Q IBDR
  1. ;
  1. ATTACH ; DEM;432 - Attachment control number.
  1. ; Ask if user wants to enter Attachment Control Number.
  1. N DIR,X,Y,DA,DIE,DR
  1. S DIR("A")="Enter Attachment Control Number"
  1. S DIR(0)="Y",DIR("B")="NO"
  1. D ^DIR
  1. Q:'Y
  1. ; User chose to enter Attachment Control Number.
  1. ; User enters Attachment Control fields.
  1. S DA(1)=IBIFN,DA=IBPROCP
  1. S DIE="^DGCR(399,"_DA(1)_",""CP"","
  1. S DR="71Report Type;72Report Transmission Method;70Attachment Control Number"
  1. D ^DIE
  1. Q
  1. ;
  1. 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'.
  1. ;
  1. N IBNOC,IBPROCEX,IBPROCIN,IBPROCNM,IBX,IBLINES,IBSTR,IBEND,IBLN
  1. S IBNOC=0
  1. I $G(IBPROCSV)="" G NOCPROCQ
  1. I $G(IBCODE)="" G NOCPROCQ
  1. I $G(IBDATE)'?7N G NOCPROCQ
  1. S IBPROCIN=$P($P(IBPROCSV,U,2),";") ;parsing out the IEN
  1. I IBPROCIN="" G NOCPROCQ
  1. ;
  1. ; If procedure code ends in '99', quit with a '1'.
  1. ;
  1. I $E(IBCODE,$L(IBCODE)-1,$L(IBCODE))=99 S IBNOC=1 G NOCPROCQ ;Does code end with 99? If so NOC
  1. ;
  1. ; Pull procedure name, then check to see if it contains one of the
  1. ; specified strings.
  1. ;
  1. S IBPROCNM=$$CPT^ICPTCOD(IBCODE,IBDATE)
  1. S IBPROCNM=$P(IBPROCNM,U,3)
  1. I IBPROCNM'="",($$NOC(IBPROCNM)) S IBNOC=1 G NOCPROCQ ; Does external match NOC strings? if so NOC
  1. ;
  1. ;Does array strings match any of the specified strings
  1. S IBLINES=$$CPTD^ICPTCOD(IBCODE,"IBINFO",,IBDATE) ;get number of lines/array of lines
  1. S IBEND=1 S:IBLINES>1 IBEND=IBLINES-1 ;set up counter for loop
  1. F IBLN=1:1:IBEND D Q:IBNOC=1 ;loop through array so we can check if node values = NOC
  1. . N IBSTR S IBSTR=$$TM($G(IBINFO(IBLN)))_" "_$$TM($G(IBINFO(IBLN+1)))_" " ;Build strings for NOC comparison
  1. . S IBNOC=$$NOC(IBSTR) ;is current combination of strings a NOC?
  1. . Q
  1. ;
  1. NOCPROCQ ; Quit out.
  1. K IBINFO ;killing the array made in CPTD^ICPTCOD
  1. Q IBNOC
  1. ;
  1. NOC(IBTEXT) ; Quit with '1' if IBTEXT contains one of the specified strings.
  1. ;
  1. S IBTEXT=$TR(IBTEXT,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. ;
  1. I IBTEXT["NOT OTHERWISE" Q 1
  1. I IBTEXT["NOT ELSEWHERE" Q 1
  1. I IBTEXT["NOT LISTED" Q 1
  1. I IBTEXT["UNLISTED" Q 1
  1. I IBTEXT["UNSPECIFIED" Q 1
  1. I IBTEXT["UNCLASSIFIED" Q 1
  1. I IBTEXT["NON-SPECIFIED" Q 1
  1. I IBTEXT["NOS " Q 1
  1. I IBTEXT["NOS;" Q 1
  1. I IBTEXT["NOS." Q 1
  1. I IBTEXT["NOS," Q 1
  1. I IBTEXT["NOS/" Q 1
  1. I IBTEXT["(NOS)" Q 1
  1. I IBTEXT["NOC " Q 1
  1. I IBTEXT["NOC;" Q 1
  1. I IBTEXT["NOC." Q 1
  1. I IBTEXT["NOC," Q 1
  1. I IBTEXT["NOC/" Q 1
  1. I IBTEXT["(NOC)" Q 1
  1. ;
  1. ; Check if last three charcters are 'NOC' or 'NOS'.
  1. ;
  1. S IBTEXT=$E(IBTEXT,$L(IBTEXT)-2,$L(IBTEXT))
  1. Q 0
  1. ;
  1. TM(IBX,IBY) ; Trim Character Y - Default " "
  1. S IBX=$G(IBX) Q:IBX="" IBX S IBY=$G(IBY) S:'$L(IBY) IBY=" "
  1. F Q:$E(IBX,1)'=IBY S IBX=$E(IBX,2,$L(IBX))
  1. F Q:$E(IBX,$L(IBX))'=IBY S IBX=$E(IBX,1,($L(IBX)-1))
  1. Q IBX
  1. ;
  1. ORALCAV(FLD) ;EP;IB*2.0*592
  1. ; Dictionary Screen function called from Procedures Oral Cavity Fields:
  1. ; 399.0304.90.01, 399.0304.90.02, 399.0304.90.03, 399.0304.90.04, 399.0304.90.05
  1. ; Prevents the same Oral Cavity from being selected more than once.
  1. ; Input: FLD - Field # of the field being checked
  1. ; DA - IEN of the Service Line Multiple being edited
  1. ; DA(1) - IEN of the 399 entry being edited
  1. ; Y - Internal Value of the user response
  1. ; Returns: 1 - Data input by the user is valid, 0 otherwise
  1. N NDE,RTN
  1. S NDE=$G(^DGCR(399,DA(1),"CP",DA,"DEN"))
  1. S RTN=1 ; Assume Valid Input
  1. Q:Y="" 1 ; No value entered
  1. ;
  1. ; Make sure there are no duplicates
  1. I FLD=90.01 D Q RTN
  1. . I $P(NDE,"^",2)=Y S RTN=0 Q
  1. . I $P(NDE,"^",3)=Y S RTN=0 Q
  1. . I $P(NDE,"^",4)=Y S RTN=0 Q
  1. . I $P(NDE,"^",5)=Y S RTN=0 Q
  1. I FLD=90.02 D Q RTN
  1. . I $P(NDE,"^",1)=Y S RTN=0 Q
  1. . I $P(NDE,"^",3)=Y S RTN=0 Q
  1. . I $P(NDE,"^",4)=Y S RTN=0 Q
  1. . I $P(NDE,"^",5)=Y S RTN=0 Q
  1. I FLD=90.03 D Q RTN
  1. . I $P(NDE,"^",1)=Y S RTN=0 Q
  1. . I $P(NDE,"^",2)=Y S RTN=0 Q
  1. . I $P(NDE,"^",4)=Y S RTN=0 Q
  1. . I $P(NDE,"^",5)=Y S RTN=0 Q
  1. I FLD=90.04 D Q RTN
  1. . I $P(NDE,"^",1)=Y S RTN=0 Q
  1. . I $P(NDE,"^",2)=Y S RTN=0 Q
  1. . I $P(NDE,"^",3)=Y S RTN=0 Q
  1. . I $P(NDE,"^",5)=Y S RTN=0 Q
  1. I FLD=90.05 D Q RTN
  1. . I $P(NDE,"^",1)=Y S RTN=0 Q
  1. . I $P(NDE,"^",2)=Y S RTN=0 Q
  1. . I $P(NDE,"^",3)=Y S RTN=0 Q
  1. . I $P(NDE,"^",4)=Y S RTN=0 Q
  1. Q RTN
  1. ;
  1. TOOTHS(FLD) ;EP;IB*2.0*592
  1. ; Dictionary Screen function called from Dental Service Line Tooth fields:
  1. ; 399,91,.02, 399,91,.03, 399,91,.04, 399,91,.05, 399,91,.06. Prevents the
  1. ; same Tooth Surface from being selected more than once.
  1. ; Input: FLD - Field # of the field being checked
  1. ; DA - Tooth Surface multiple IEN
  1. ; DA(1) - Service Line multiple IEN
  1. ; DA(2) - IEN of the 399 entry being edited
  1. ; Y - Internal Value of the user response
  1. ; Returns: 1 - Data input by the user is valid, 0 otherwise
  1. N NDE,RTN
  1. S NDE=$G(^DGCR(399,DA(2),"CP",DA(1),"DEN1",DA,0))
  1. S RTN=1 ; Assume Valid Input
  1. Q:Y="" 1 ; No value entered
  1. ;
  1. ; Make sure there are no duplicates
  1. I FLD=.02 D Q RTN
  1. . I $P(NDE,"^",3)=Y S RTN=0 Q
  1. . I $P(NDE,"^",4)=Y S RTN=0 Q
  1. . I $P(NDE,"^",5)=Y S RTN=0 Q
  1. . I $P(NDE,"^",6)=Y S RTN=0 Q
  1. I FLD=.03 D Q RTN
  1. . I $P(NDE,"^",2)=Y S RTN=0 Q
  1. . I $P(NDE,"^",4)=Y S RTN=0 Q
  1. . I $P(NDE,"^",5)=Y S RTN=0 Q
  1. . I $P(NDE,"^",6)=Y S RTN=0 Q
  1. I FLD=.04 D Q RTN
  1. . I $P(NDE,"^",2)=Y S RTN=0 Q
  1. . I $P(NDE,"^",3)=Y S RTN=0 Q
  1. . I $P(NDE,"^",5)=Y S RTN=0 Q
  1. . I $P(NDE,"^",6)=Y S RTN=0 Q
  1. I FLD=.05 D Q RTN
  1. . I $P(NDE,"^",2)=Y S RTN=0 Q
  1. . I $P(NDE,"^",3)=Y S RTN=0 Q
  1. . I $P(NDE,"^",4)=Y S RTN=0 Q
  1. . I $P(NDE,"^",6)=Y S RTN=0 Q
  1. I FLD=.06 D Q RTN
  1. . I $P(NDE,"^",2)=Y S RTN=0 Q
  1. . I $P(NDE,"^",3)=Y S RTN=0 Q
  1. . I $P(NDE,"^",4)=Y S RTN=0 Q
  1. . I $P(NDE,"^",5)=Y S RTN=0 Q
  1. Q RTN
  1. ;