- SROMOD ;BIR/ADM - CPT Modifier Input ; [ 02/27/01 6:32 AM ]
- ;;3.0; Surgery ;**88,100,127**;24 Jun 93
- Q
- DISPLAY ; display name with modifier
- N SRY,SRDA,SRDATE S SRDATE=DT
- S SRDA=$S($G(SRTN):SRTN,$D(DA(1)):DA(1),$D(DA):DA,1:"")
- I $G(SRDA) S SRDATE=$P($G(^SRF(SRDA,0)),"^",9)
- S SRY=$$MOD^ICPTMOD(Y,"I",SRDATE) Q:$P(SRY,"^")=-1
- S Y=$P(SRY,"^",2)_" "_$P(SRY,"^",3)
- Q
- SCR27() ; screen for acceptable CPT code/modifier pair for principal procedure
- N SRCODE,SRDA,SRCMOD,SROK,SRSDATE,SRZ D PCHK K SRM
- Q SROK
- PCHK ; return value of modifier if acceptable for principal procedure
- N SRSDATE S SRSDATE=DT K ICPTVDT
- S SROK=0,SRCODE="",SRDA=$S($G(SRTN):SRTN,$D(DA(1)):DA(1),$D(DA):DA,1:""),SRM=$S($D(SRM):SRM,1:+Y)
- I SRDA S SRSDATE=$P(^SRF(SRDA,0),"^",9),SRCODE=$P($G(^SRF(SRDA,"OP")),"^",2)
- I 'SRCODE Q
- S SRZ=$P($$MODP^ICPTMOD(SRCODE,SRM,"I",SRSDATE),"^") I SRZ>0 S SROK=SRZ
- S ICPTVDT=SRSDATE
- Q
- OTH() ; screen for acceptable CPT code/modifier pair for other procedure
- N SRCODE,SRDA,SRCMOD,SROK,SROTH,SRSDATE,SRZ D OCHK K SRM
- Q SROK
- OCHK ; return value of modifier if acceptable for other procedure
- N SRSDATE S SRSDATE=DT K ICPTVDT
- S SROK=0,SRCODE="",SRDA=$S($G(SRTN):SRTN,$D(DA(2)):DA(2),$D(DA(1)):DA(1),$D(D0):D0,1:""),SROTH=$S($D(DA):DA,$D(D1):D1,1:""),SRM=$S($D(SRM):SRM,1:+Y)
- I SRDA&SROTH S SRSDATE=$P(^SRF(SRDA,0),"^",9),SRCODE=$P($G(^SRF(SRDA,13,SROTH,2)),"^")
- I 'SRCODE Q
- S SRZ=$P($$MODP^ICPTMOD(SRCODE,SRM,"I",SRSDATE),"^") I SRZ>0 S SROK=SRZ
- S ICPTVDT=SRSDATE
- Q
- SPRIN ; set logic for ACPT x-ref
- Q:$E($G(IOST))'="C"!($G(DIK)'="")
- N SRCODE,SRDA,SRDEF,SRIEN,SRJ,SRQ,SRSDATE,SRSEL,SRSOUT,SRX,SRY,Z S (SRQ,SRSOUT)=0,SRCODE=X N X I $D(SRCMOD) D HYPH27
- S SRDA=DA,SRIEN=$O(^SRF(SRDA,"OPMOD","AAA"),-1) I SRIEN S SRX=$P(^SRF(SRDA,"OPMOD",SRIEN,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRX,"I"),"^",2)
- K DIR F D K SRM,SRCMOD Q:SRSOUT S SRQ=0
- .S DIR("A")=" Modifier: ",DIR(0)="130.028,.01AO" S:$G(SRCMOD)'="" DIR("B")=SRCMOD D:$O(^SRF(SRDA,"OPMOD",0)) QUES
- .D ^DIR K DIR S DA=SRDA I $D(DTOUT)!$D(DUOUT)!(X="") S SRSOUT=1 Q
- .I +Y S SRJ=0 F S SRJ=$O(^SRF(SRDA,"OPMOD",SRJ)) Q:'SRJ I $P(^SRF(SRDA,"OPMOD",SRJ,0),"^")=+Y N DIR D Q
- ..S SRSEL=Y(0),DIR(0)="130.028,.01AO",DIR("A")=" Modifier: ",DIR("B")=$P(Y(0),"^")
- ..D ^DIR S DA=SRDA I $D(DTOUT)!$D(DUOUT)!(X="") S SRSOUT=1 Q
- ..I +Y S SRK=0 F S SRK=$O(^SRF(SRDA,"OPMOD",SRK)) Q:'SRK I $P(^SRF(SRDA,"OPMOD",SRK,0),"^")=+Y S SRQ=1 Q
- ..Q:SRQ I +Y S $P(^SRF(SRDA,"OPMOD",SRJ,0),"^")=+Y,SRQ=1 Q
- ..I X="@" S SRY(130.028,SRJ_","_SRDA_",",.01)="@" D FILE^DIE("","SRY"),EN^DDIOL(" ... Modifier deleted","","?20") S SRQ=1
- .Q:SRQ!SRSOUT
- .I +Y S SRY(130.028,"+1,"_DA_",",.01)=+Y D UPDATE^DIE("","SRY") Q
- .I X="@",$D(SRCMOD) S SRY(130.028,SRIEN_","_SRDA_",",.01)="@" D FILE^DIE("","SRY"),EN^DDIOL(" ... Modifier deleted","","?20")
- Q
- KPRIN ; kill logic for ACPT x-ref
- Q:$E($G(IOST))'="C"!($G(DIK)'="") K ^SRF(DA,"OPMOD")
- Q
- SOTH ; set logic for ACPT1 x-ref
- Q:$E($G(IOST))'="C"!($G(DIK)'="")
- N SRCODE,SRDA,SRDEF,SRIEN,SRJ,SRQ,SRSDATE,SRSEL,SRSOUT,SRX,SRY,Z S (SRQ,SRSOUT)=0,SRCODE=X N X I $D(SRCMOD) D HYPHOTH
- S SRDA=DA,SRDA(1)=DA(1),SRIEN=$O(^SRF(SRDA(1),13,SRDA,"MOD","A"),-1) I SRIEN S SRX=$P(^SRF(SRDA(1),13,SRDA,"MOD",SRIEN,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRX,"I"),"^",2)
- K DIR F D K SRM,SRCMOD Q:SRSOUT S SRQ=0
- .S DIR("A")=" Modifier: ",DIR(0)="130.164,.01AO" S:$G(SRCMOD)'="" DIR("B")=SRCMOD D:$O(^SRF(SRDA(1),13,SRDA,"MOD",0)) QUES1
- .D ^DIR K DIR S DA=SRDA,DA(1)=SRDA(1) I $D(DTOUT)!$D(DUOUT)!(X="") S SRSOUT=1 Q
- .I +Y S SRJ=0 F S SRJ=$O(^SRF(SRDA(1),13,SRDA,"MOD",SRJ)) Q:'SRJ I $P(^SRF(SRDA(1),13,SRDA,"MOD",SRJ,0),"^")=+Y N DIR D Q
- ..S SRSEL=Y(0),DIR(0)="130.164,.01AO",DIR("A")=" Modifier: ",DIR("B")=$P(Y(0),"^")
- ..D ^DIR S DA=SRDA I $D(DTOUT)!$D(DUOUT)!(X="") S SRSOUT=1 Q
- ..I +Y S SRK=0 F S SRK=$O(^SRF(SRDA(1),13,SRDA,"MOD",SRK)) Q:'SRK I $P(^SRF(SRDA(1),13,SRDA,"MOD",SRK,0),"^")=+Y S Y="" Q
- ..I X="@" S SRY(130.164,SRJ_","_SRDA_","_SRDA(1)_",",.01)="@" D FILE^DIE("","SRY"),EN^DDIOL(" ... Modifier deleted","","?20") S SRQ=1
- .Q:SRQ!SRSOUT
- .I +Y S SRY(130.164,"+1,"_DA_","_DA(1)_",",.01)=+Y D UPDATE^DIE("","SRY") Q
- .I X="@",$D(SRCMOD) S SRY(130.164,SRIEN_","_SRDA_",",SRDA(1)_",",.01)="@" D FILE^DIE("","SRY"),EN^DDIOL(" ... Modifier deleted","","?20")
- Q
- KOTH ; kill logic for ACPT1 x-ref
- Q:$E($G(IOST))'="C"!($G(DIK)'="") K ^SRF(DA(1),13,DA,"MOD")
- Q
- HYPH27 ; input CPT hyphenated modifier for principal procedure
- N SRCODE,SRDA,SRDUP,SRLIST,SRN,SROK,SRY S SRLIST=SRCMOD
- F SRN=1:1 S SRCMOD=$P(SRLIST,",",SRN) Q:SRCMOD="" D
- .S (SRDUP,SROK)=0
- .S SRM=$P($$MOD^ICPTMOD(SRCMOD),"^") K:SRM<0 SRM I $D(SRM) D PCHK K SRM
- .I 'SROK D EN^DDIOL("CPT Modifier '"_SRCMOD_"' is not acceptable with this CPT code.","","!") K SRCMOD Q
- .S SRJ=0 F S SRJ=$O(^SRF(SRDA,"OPMOD",SRJ)) Q:'SRJ I $P(^SRF(SRDA,"OPMOD",SRJ,0),"^")=SROK S SRDUP=1 Q
- .I 'SRDUP S SRY(130.028,"+1,"_DA_",",.01)=SROK D UPDATE^DIE("","SRY")
- Q
- HYPHOTH ; input CPT hyphenated modifier for other procedure
- N SRCODE,SRDA,SRDUP,SRLIST,SRN,SROK,SROTH,SRY S SRLIST=SRCMOD
- F SRN=1:1 S SRCMOD=$P(SRLIST,",",SRN) Q:SRCMOD="" D
- .S (SRDUP,SROK)=0
- .S SRM=$P($$MOD^ICPTMOD(SRCMOD),"^") K:SRM<0 SRM I $D(SRM) D OCHK K SRM
- .I 'SROK D EN^DDIOL("CPT Modifier '"_SRCMOD_"' is not acceptable with this CPT code.","","!") K SRCMOD Q
- .S SRJ=0 F S SRJ=$O(^SRF(SRDA,13,SROTH,"MOD",SRJ)) Q:'SRJ I $P(^SRF(SRDA,13,SROTH,"MOD",SRJ,0),"^")=SROK S SRDUP=1 Q
- .I 'SRDUP S SRY(130.164,"+1,"_DA_","_DA(1)_",",.01)=SROK D UPDATE^DIE("","SRY")
- Q
- QUES N SRI,SRMD,SRX,SRY,SRZ S DIR("?",1)=" Answer with PRIN. PROCEDURE CPT MODIFIER",DIR("?",2)="Choose from:"
- S SRI=0,SRCT=3 F S SRI=$O(^SRF(SRDA,"OPMOD",SRI)) Q:'SRI S SRMD=$P(^SRF(SRDA,"OPMOD",SRI,0),"^") D
- .S SRX=$$MOD^ICPTMOD(SRMD,"I",$P($G(^SRF(SRDA,0)),"^",9)),SRY=$P(SRX,"^",2),SRZ=$P(SRX,"^",3)
- .S DIR("?",SRCT)=" "_SRY_" "_SRZ,SRCT=SRCT+1
- S DIR("?",SRCT)="",DIR("?")=" You may enter a new PRIN. PROCEDURE CPT MODIFIER, if you wish."
- Q
- QUES1 N SRI,SRMD,SRX,SRY,SRZ S DIR("?",1)=" Answer with OTHER PROCEDURE CPT MODIFIER",DIR("?",2)="Choose from:"
- S SRI=0,SRCT=3 F S SRI=$O(^SRF(SRDA(1),13,SRDA,"MOD",SRI)) Q:'SRI S SRMD=$P(^SRF(SRDA(1),13,SRDA,"MOD",SRI,0),"^") D
- .S SRX=$$MOD^ICPTMOD(SRMD,"I",$P($G(^SRF(SRDA,0)),"^",9)),SRY=$P(SRX,"^",2),SRZ=$P(SRX,"^",3)
- .S DIR("?",SRCT)=" "_SRY_" "_SRZ,SRCT=SRCT+1
- S DIR("?",SRCT)="",DIR("?")=" You may enter a new OTHER PROCEDURE CPT MODIFIER, if you wish."
- Q
-
- SROMOD ;BIR/ADM - CPT Modifier Input ; [ 02/27/01 6:32 AM ]
- +1 ;;3.0; Surgery ;**88,100,127**;24 Jun 93
- +2 QUIT
- DISPLAY ; display name with modifier
- +1 NEW SRY,SRDA,SRDATE
- SET SRDATE=DT
- +2 SET SRDA=$SELECT($GET(SRTN):SRTN,$DATA(DA(1)):DA(1),$DATA(DA):DA,1:"")
- +3 IF $GET(SRDA)
- SET SRDATE=$PIECE($GET(^SRF(SRDA,0)),"^",9)
- +4 SET SRY=$$MOD^ICPTMOD(Y,"I",SRDATE)
- IF $PIECE(SRY,"^")=-1
- QUIT
- +5 SET Y=$PIECE(SRY,"^",2)_" "_$PIECE(SRY,"^",3)
- +6 QUIT
- SCR27() ; screen for acceptable CPT code/modifier pair for principal procedure
- +1 NEW SRCODE,SRDA,SRCMOD,SROK,SRSDATE,SRZ
- DO PCHK
- KILL SRM
- +2 QUIT SROK
- PCHK ; return value of modifier if acceptable for principal procedure
- +1 NEW SRSDATE
- SET SRSDATE=DT
- KILL ICPTVDT
- +2 SET SROK=0
- SET SRCODE=""
- SET SRDA=$SELECT($GET(SRTN):SRTN,$DATA(DA(1)):DA(1),$DATA(DA):DA,1:"")
- SET SRM=$SELECT($DATA(SRM):SRM,1:+Y)
- +3 IF SRDA
- SET SRSDATE=$PIECE(^SRF(SRDA,0),"^",9)
- SET SRCODE=$PIECE($GET(^SRF(SRDA,"OP")),"^",2)
- +4 IF 'SRCODE
- QUIT
- +5 SET SRZ=$PIECE($$MODP^ICPTMOD(SRCODE,SRM,"I",SRSDATE),"^")
- IF SRZ>0
- SET SROK=SRZ
- +6 SET ICPTVDT=SRSDATE
- +7 QUIT
- OTH() ; screen for acceptable CPT code/modifier pair for other procedure
- +1 NEW SRCODE,SRDA,SRCMOD,SROK,SROTH,SRSDATE,SRZ
- DO OCHK
- KILL SRM
- +2 QUIT SROK
- OCHK ; return value of modifier if acceptable for other procedure
- +1 NEW SRSDATE
- SET SRSDATE=DT
- KILL ICPTVDT
- +2 SET SROK=0
- SET SRCODE=""
- SET SRDA=$SELECT($GET(SRTN):SRTN,$DATA(DA(2)):DA(2),$DATA(DA(1)):DA(1),$DATA(D0):D0,1:"")
- SET SROTH=$SELECT($DATA(DA):DA,$DATA(D1):D1,1:"")
- SET SRM=$SELECT($DATA(SRM):SRM,1:+Y)
- +3 IF SRDA&SROTH
- SET SRSDATE=$PIECE(^SRF(SRDA,0),"^",9)
- SET SRCODE=$PIECE($GET(^SRF(SRDA,13,SROTH,2)),"^")
- +4 IF 'SRCODE
- QUIT
- +5 SET SRZ=$PIECE($$MODP^ICPTMOD(SRCODE,SRM,"I",SRSDATE),"^")
- IF SRZ>0
- SET SROK=SRZ
- +6 SET ICPTVDT=SRSDATE
- +7 QUIT
- SPRIN ; set logic for ACPT x-ref
- +1 IF $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
- QUIT
- +2 NEW SRCODE,SRDA,SRDEF,SRIEN,SRJ,SRQ,SRSDATE,SRSEL,SRSOUT,SRX,SRY,Z
- SET (SRQ,SRSOUT)=0
- SET SRCODE=X
- NEW X
- IF $DATA(SRCMOD)
- DO HYPH27
- +3 SET SRDA=DA
- SET SRIEN=$ORDER(^SRF(SRDA,"OPMOD","AAA"),-1)
- IF SRIEN
- SET SRX=$PIECE(^SRF(SRDA,"OPMOD",SRIEN,0),"^")
- SET SRCMOD=$PIECE($$MOD^ICPTMOD(SRX,"I"),"^",2)
- +4 KILL DIR
- FOR
- Begin DoDot:1
- +5 SET DIR("A")=" Modifier: "
- SET DIR(0)="130.028,.01AO"
- IF $GET(SRCMOD)'=""
- SET DIR("B")=SRCMOD
- IF $ORDER(^SRF(SRDA,"OPMOD",0))
- DO QUES
- +6 DO ^DIR
- KILL DIR
- SET DA=SRDA
- IF $DATA(DTOUT)!$DATA(DUOUT)!(X="")
- SET SRSOUT=1
- QUIT
- +7 IF +Y
- SET SRJ=0
- FOR
- SET SRJ=$ORDER(^SRF(SRDA,"OPMOD",SRJ))
- IF 'SRJ
- QUIT
- IF $PIECE(^SRF(SRDA,"OPMOD",SRJ,0),"^")=+Y
- NEW DIR
- Begin DoDot:2
- +8 SET SRSEL=Y(0)
- SET DIR(0)="130.028,.01AO"
- SET DIR("A")=" Modifier: "
- SET DIR("B")=$PIECE(Y(0),"^")
- +9 DO ^DIR
- SET DA=SRDA
- IF $DATA(DTOUT)!$DATA(DUOUT)!(X="")
- SET SRSOUT=1
- QUIT
- +10 IF +Y
- SET SRK=0
- FOR
- SET SRK=$ORDER(^SRF(SRDA,"OPMOD",SRK))
- IF 'SRK
- QUIT
- IF $PIECE(^SRF(SRDA,"OPMOD",SRK,0),"^")=+Y
- SET SRQ=1
- QUIT
- +11 IF SRQ
- QUIT
- IF +Y
- SET $PIECE(^SRF(SRDA,"OPMOD",SRJ,0),"^")=+Y
- SET SRQ=1
- QUIT
- +12 IF X="@"
- SET SRY(130.028,SRJ_","_SRDA_",",.01)="@"
- DO FILE^DIE("","SRY")
- DO EN^DDIOL(" ... Modifier deleted","","?20")
- SET SRQ=1
- End DoDot:2
- QUIT
- +13 IF SRQ!SRSOUT
- QUIT
- +14 IF +Y
- SET SRY(130.028,"+1,"_DA_",",.01)=+Y
- DO UPDATE^DIE("","SRY")
- QUIT
- +15 IF X="@"
- IF $DATA(SRCMOD)
- SET SRY(130.028,SRIEN_","_SRDA_",",.01)="@"
- DO FILE^DIE("","SRY")
- DO EN^DDIOL(" ... Modifier deleted","","?20")
- End DoDot:1
- KILL SRM,SRCMOD
- IF SRSOUT
- QUIT
- SET SRQ=0
- +16 QUIT
- KPRIN ; kill logic for ACPT x-ref
- +1 IF $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
- QUIT
- KILL ^SRF(DA,"OPMOD")
- +2 QUIT
- SOTH ; set logic for ACPT1 x-ref
- +1 IF $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
- QUIT
- +2 NEW SRCODE,SRDA,SRDEF,SRIEN,SRJ,SRQ,SRSDATE,SRSEL,SRSOUT,SRX,SRY,Z
- SET (SRQ,SRSOUT)=0
- SET SRCODE=X
- NEW X
- IF $DATA(SRCMOD)
- DO HYPHOTH
- +3 SET SRDA=DA
- SET SRDA(1)=DA(1)
- SET SRIEN=$ORDER(^SRF(SRDA(1),13,SRDA,"MOD","A"),-1)
- IF SRIEN
- SET SRX=$PIECE(^SRF(SRDA(1),13,SRDA,"MOD",SRIEN,0),"^")
- SET SRCMOD=$PIECE($$MOD^ICPTMOD(SRX,"I"),"^",2)
- +4 KILL DIR
- FOR
- Begin DoDot:1
- +5 SET DIR("A")=" Modifier: "
- SET DIR(0)="130.164,.01AO"
- IF $GET(SRCMOD)'=""
- SET DIR("B")=SRCMOD
- IF $ORDER(^SRF(SRDA(1),13,SRDA,"MOD",0))
- DO QUES1
- +6 DO ^DIR
- KILL DIR
- SET DA=SRDA
- SET DA(1)=SRDA(1)
- IF $DATA(DTOUT)!$DATA(DUOUT)!(X="")
- SET SRSOUT=1
- QUIT
- +7 IF +Y
- SET SRJ=0
- FOR
- SET SRJ=$ORDER(^SRF(SRDA(1),13,SRDA,"MOD",SRJ))
- IF 'SRJ
- QUIT
- IF $PIECE(^SRF(SRDA(1),13,SRDA,"MOD",SRJ,0),"^")=+Y
- NEW DIR
- Begin DoDot:2
- +8 SET SRSEL=Y(0)
- SET DIR(0)="130.164,.01AO"
- SET DIR("A")=" Modifier: "
- SET DIR("B")=$PIECE(Y(0),"^")
- +9 DO ^DIR
- SET DA=SRDA
- IF $DATA(DTOUT)!$DATA(DUOUT)!(X="")
- SET SRSOUT=1
- QUIT
- +10 IF +Y
- SET SRK=0
- FOR
- SET SRK=$ORDER(^SRF(SRDA(1),13,SRDA,"MOD",SRK))
- IF 'SRK
- QUIT
- IF $PIECE(^SRF(SRDA(1),13,SRDA,"MOD",SRK,0),"^")=+Y
- SET Y=""
- QUIT
- +11 IF X="@"
- SET SRY(130.164,SRJ_","_SRDA_","_SRDA(1)_",",.01)="@"
- DO FILE^DIE("","SRY")
- DO EN^DDIOL(" ... Modifier deleted","","?20")
- SET SRQ=1
- End DoDot:2
- QUIT
- +12 IF SRQ!SRSOUT
- QUIT
- +13 IF +Y
- SET SRY(130.164,"+1,"_DA_","_DA(1)_",",.01)=+Y
- DO UPDATE^DIE("","SRY")
- QUIT
- +14 IF X="@"
- IF $DATA(SRCMOD)
- SET SRY(130.164,SRIEN_","_SRDA_",",SRDA(1)_",",.01)="@"
- DO FILE^DIE("","SRY")
- DO EN^DDIOL(" ... Modifier deleted","","?20")
- End DoDot:1
- KILL SRM,SRCMOD
- IF SRSOUT
- QUIT
- SET SRQ=0
- +15 QUIT
- KOTH ; kill logic for ACPT1 x-ref
- +1 IF $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
- QUIT
- KILL ^SRF(DA(1),13,DA,"MOD")
- +2 QUIT
- HYPH27 ; input CPT hyphenated modifier for principal procedure
- +1 NEW SRCODE,SRDA,SRDUP,SRLIST,SRN,SROK,SRY
- SET SRLIST=SRCMOD
- +2 FOR SRN=1:1
- SET SRCMOD=$PIECE(SRLIST,",",SRN)
- IF SRCMOD=""
- QUIT
- Begin DoDot:1
- +3 SET (SRDUP,SROK)=0
- +4 SET SRM=$PIECE($$MOD^ICPTMOD(SRCMOD),"^")
- IF SRM<0
- KILL SRM
- IF $DATA(SRM)
- DO PCHK
- KILL SRM
- +5 IF 'SROK
- DO EN^DDIOL("CPT Modifier '"_SRCMOD_"' is not acceptable with this CPT code.","","!")
- KILL SRCMOD
- QUIT
- +6 SET SRJ=0
- FOR
- SET SRJ=$ORDER(^SRF(SRDA,"OPMOD",SRJ))
- IF 'SRJ
- QUIT
- IF $PIECE(^SRF(SRDA,"OPMOD",SRJ,0),"^")=SROK
- SET SRDUP=1
- QUIT
- +7 IF 'SRDUP
- SET SRY(130.028,"+1,"_DA_",",.01)=SROK
- DO UPDATE^DIE("","SRY")
- End DoDot:1
- +8 QUIT
- HYPHOTH ; input CPT hyphenated modifier for other procedure
- +1 NEW SRCODE,SRDA,SRDUP,SRLIST,SRN,SROK,SROTH,SRY
- SET SRLIST=SRCMOD
- +2 FOR SRN=1:1
- SET SRCMOD=$PIECE(SRLIST,",",SRN)
- IF SRCMOD=""
- QUIT
- Begin DoDot:1
- +3 SET (SRDUP,SROK)=0
- +4 SET SRM=$PIECE($$MOD^ICPTMOD(SRCMOD),"^")
- IF SRM<0
- KILL SRM
- IF $DATA(SRM)
- DO OCHK
- KILL SRM
- +5 IF 'SROK
- DO EN^DDIOL("CPT Modifier '"_SRCMOD_"' is not acceptable with this CPT code.","","!")
- KILL SRCMOD
- QUIT
- +6 SET SRJ=0
- FOR
- SET SRJ=$ORDER(^SRF(SRDA,13,SROTH,"MOD",SRJ))
- IF 'SRJ
- QUIT
- IF $PIECE(^SRF(SRDA,13,SROTH,"MOD",SRJ,0),"^")=SROK
- SET SRDUP=1
- QUIT
- +7 IF 'SRDUP
- SET SRY(130.164,"+1,"_DA_","_DA(1)_",",.01)=SROK
- DO UPDATE^DIE("","SRY")
- End DoDot:1
- +8 QUIT
- QUES NEW SRI,SRMD,SRX,SRY,SRZ
- SET DIR("?",1)=" Answer with PRIN. PROCEDURE CPT MODIFIER"
- SET DIR("?",2)="Choose from:"
- +1 SET SRI=0
- SET SRCT=3
- FOR
- SET SRI=$ORDER(^SRF(SRDA,"OPMOD",SRI))
- IF 'SRI
- QUIT
- SET SRMD=$PIECE(^SRF(SRDA,"OPMOD",SRI,0),"^")
- Begin DoDot:1
- +2 SET SRX=$$MOD^ICPTMOD(SRMD,"I",$PIECE($GET(^SRF(SRDA,0)),"^",9))
- SET SRY=$PIECE(SRX,"^",2)
- SET SRZ=$PIECE(SRX,"^",3)
- +3 SET DIR("?",SRCT)=" "_SRY_" "_SRZ
- SET SRCT=SRCT+1
- End DoDot:1
- +4 SET DIR("?",SRCT)=""
- SET DIR("?")=" You may enter a new PRIN. PROCEDURE CPT MODIFIER, if you wish."
- +5 QUIT
- QUES1 NEW SRI,SRMD,SRX,SRY,SRZ
- SET DIR("?",1)=" Answer with OTHER PROCEDURE CPT MODIFIER"
- SET DIR("?",2)="Choose from:"
- +1 SET SRI=0
- SET SRCT=3
- FOR
- SET SRI=$ORDER(^SRF(SRDA(1),13,SRDA,"MOD",SRI))
- IF 'SRI
- QUIT
- SET SRMD=$PIECE(^SRF(SRDA(1),13,SRDA,"MOD",SRI,0),"^")
- Begin DoDot:1
- +2 SET SRX=$$MOD^ICPTMOD(SRMD,"I",$PIECE($GET(^SRF(SRDA,0)),"^",9))
- SET SRY=$PIECE(SRX,"^",2)
- SET SRZ=$PIECE(SRX,"^",3)
- +3 SET DIR("?",SRCT)=" "_SRY_" "_SRZ
- SET SRCT=SRCT+1
- End DoDot:1
- +4 SET DIR("?",SRCT)=""
- SET DIR("?")=" You may enter a new OTHER PROCEDURE CPT MODIFIER, if you wish."
- +5 QUIT
- +6
- ***** ERRORS & WARNINGS IN SROMOD *****
- SROMOD+1 S - 2nd line of routine violates the SAC.
