IBCU7C ;EDE/WCJ - LINE LEVEL MODIFIER SELECTION ;10-NOV-2022
;;2.0;INTEGRATED BILLING;**742,759**;21-MAR-94;Build 24
;;Per VA Directive 6402, this routine should not be modified.
G AWAY
AWAY Q
;
EN(IBPROCP) ;
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
N MODARR,SAVEDA,SAVEDIC,CNT,FIRST,DELETE
M SAVEDA=DA,SAVEDIC=DIC
N DA,DIC
N DIE,DR,DLAYGO,LOOP ;WCJ;IB759;missed NEW'ing some variables in IB742 version which promptly bit me in the a$$ - at least one of them did so fixing them all.
S FIRST=1
;
AGAIN K MODARR,DA,DIC,CNT,DIR
M DA=SAVEDA,DIC=SAVEDIC
S DELETE=0
D GETXIST(IBPROCP,.MODARR,.DA)
;
S CNT=$O(MODARR("A"),-1)
S DIR("?")="Type a unique sequence number between 1 and 10, 0 Decimal Digits"
I CNT>0 D
. N LAST
. S DIR("?",1)="CPT MOD SEQ CPT MODIFER"
. F LOOP=1:1:CNT D
.. S DIR("?",LOOP+1)=" "_$P(MODARR(LOOP),U,4)_" "_$S($L($P(MODARR(LOOP),U,4))=1:" ",1:"")_$P(MODARR(LOOP),U)_" "_$$GET1^DIQ(81.3,$P(MODARR(LOOP),U,2)_",",.02)
. S LAST=$O(MODARR("ZZREF2",""),-1)
. I FIRST,+LAST S DIR("B")=$P(MODARR("ZZREF2",LAST),U,4),FIRST=0
;
S DIR(0)="FO^1:2"
S DIR("A")="Select CPT MODIFIER SEQUENCE"
D ^DIR
Q:X=""!(X="^")
;
Q:$D(DIROUT)!$D(DTOUT) ; quit if ^ or time out ;WCJ;IB742 v15
Q:$D(DIRUT)&'$G(DIR("B")) ; if user entere @ but there was no default, quit because nothing to delete ;WCJ;IB742 v15
;
;WCJ;IB742 v15
;user entred an @ so they are delting the default
I $D(DIRUT) D
. S FIRST=1 ; rest so it defaults again after deletion
. S X=$G(DIR("B"))
. S DELETE=1
;
; an existing exact match on an external modifier so the question is which one.
I $D(MODARR("ZZREF3",X)) D G AGAIN
. S (DA,Y)=$P(MODARR("ZZREF3",X,$O(MODARR("ZZREF3",X,""))),U,3) ; grab the first one for now.
. I $O(MODARR("ZZREF3",X,""))'=$O(MODARR("ZZREF3",X,"A"),-1) D Q:Y=-1 ; check to see if the first/last are the same - quit for now if it isn't
.. N DIC
.. S DIC(0)="EMX"
.. S DIC="^DGCR(399,"_DA(1)_",""CP"","_+IBPROCP_",""MOD"","
.. D ^DIC
.. Q:Y=-1
.. S DA=+Y
.;
. S DA(2)=DA(1),DA(1)=+IBPROCP
. S (DIC,DIE)="^DGCR(399,"_DA(2)_",""CP"",DA(1),""MOD"","
. S DR=".01 CPT MODIFIER SEQUENCE;.02 CPT MODIFIER"
. D ^DIE
;
I +X'=X!(X>10)!(X<1)!(X?.E1"."1N.N) D G AGAIN ; no exact match and not a whole number so question input and ask again
. W !,DIR("?"),!
. Q
;
; We have an existing SEQ number (that kind of worked)
I $D(MODARR("ZZREF2",X)) D G AGAIN
. N SEQ
. S SEQ=X
. S DA(2)=DA(1),DA(1)=+IBPROCP,(DA,Y)=$P(MODARR("ZZREF2",X),U,3)
. S (DIC,DIE)="^DGCR(399,"_DA(2)_",""CP"",DA(1),""MOD"","
. S DIC(0)="L"
. S DR=".01 CPT MODIFIER SEQUENCE"_$S(DELETE:"////@",1:";.02 CPT MODIFER") ;WCJ;IB742 v15
. D ^DIE
. I DELETE D EN^DDIOL("THE ENTIRE '"_SEQ_"' CPT MODIFIER SEQUENCE WAS DELETED") ;WCJ;IB742 v15
;
; We have a new seq #
I '$D(MODARR("ZZREF2",X)) D G AGAIN
. S DLAYGO=399
. S DA(2)=DA(1),DA(1)=+IBPROCP
. S DIC="^DGCR(399,"_DA(2)_",""CP"",DA(1),""MOD"","
. S DIC("DR")=".02"
. S DIC(0)="L"
. K DD,DO
. D FILE^DICN
;
Q
;
GETXIST(IBPROCP,MODARR,DA) ; check to see if this code has already been entered as a modifier for this procedure.
; IN
; IBPROCP - conatins subfile IEN of which procedure we are working with
; OUT
; MODARR - an array with modifier information for this procedure
;
; MODARR("ZZREF1",EXTERNAL MODIFIER,CPTSEQNUMBER) = IEN81P3^IENSUBFILE^SEQUENCE NUMBER
; MODARR("ZZREF2",IEN81P3,CPTSEQNUMBER) = IEN81P3^IENSUBFILE^SEQUENCE NUMBER
; MODARR("ZZREF3",CPTSEQNUMBER) = IEN81P3^IENSUBFILE^SEQUENCE NUMBER
; MODARR(COUNT) = IEN81P3^IENSUBFILE^SEQUENCE NUMBER
;
N MOD,MODIEN,MODSFIEN,MODSEQNUM,MODDATA,MODSEQ,I
;
S (MOD,MODIEN)=""
F S MODIEN=$O(^DGCR(399,DA(1),"CP",+IBPROCP,"MOD","C",MODIEN)) Q:MODIEN="" D
. S MOD=$$GET1^DIQ(81.3,MODIEN_",",.01,"E")
. ;
. S MODSFIEN=0
. F S MODSFIEN=$O(^DGCR(399,DA(1),"CP",+IBPROCP,"MOD","C",MODIEN,MODSFIEN)) Q:MODSFIEN="" D
.. S MODSEQNUM=+$G(^DGCR(399,DA(1),"CP",+IBPROCP,"MOD",MODSFIEN,0))
.. S MODDATA=MOD_U_MODIEN_U_MODSFIEN_U_MODSEQNUM
.. S MODARR("ZZREF1",MODIEN,MODSEQNUM)=MODDATA
.. S MODARR("ZZREF2",MODSEQNUM)=MODDATA
.. S MODARR("ZZREF3",MOD,MODSEQNUM)=MODDATA
;
I $D(MODARR)<10 Q
;
; reorder for display starting with 1
S MODSEQ="" F I=1:1 S MODSEQ=$O(MODARR("ZZREF2",MODSEQ)) Q:MODSEQ="" S MODARR(I)=MODARR("ZZREF2",MODSEQ)
Q
;
TEST ; amusing myself with alternate methods
;LIST^DIC(file[,iens][,fields][,flags][,number][,[.]from][,[.]part][,index][,[.]screen][,identifier][,target_root][,msg_root])
D LIST^DIC(399.30416,,".01;.02","X")
;
;FIND^DIC(file[,iens][,fields][,flags],[.]value[,number][,[.]indexes][,[.]screen][,identifier][,target_root][,msg_root])
D FIND^DIC(399.30416,",1290176,2",".01;.02")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU7C 4852 printed Apr 09, 2024@21:31:45 Page 2
IBCU7C ;EDE/WCJ - LINE LEVEL MODIFIER SELECTION ;10-NOV-2022
+1 ;;2.0;INTEGRATED BILLING;**742,759**;21-MAR-94;Build 24
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 GOTO AWAY
AWAY QUIT
+1 ;
EN(IBPROCP) ;
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 NEW MODARR,SAVEDA,SAVEDIC,CNT,FIRST,DELETE
+3 MERGE SAVEDA=DA,SAVEDIC=DIC
+4 NEW DA,DIC
+5 ;WCJ;IB759;missed NEW'ing some variables in IB742 version which promptly bit me in the a$$ - at least one of them did so fixing them all.
NEW DIE,DR,DLAYGO,LOOP
+6 SET FIRST=1
+7 ;
AGAIN KILL MODARR,DA,DIC,CNT,DIR
+1 MERGE DA=SAVEDA,DIC=SAVEDIC
+2 SET DELETE=0
+3 DO GETXIST(IBPROCP,.MODARR,.DA)
+4 ;
+5 SET CNT=$ORDER(MODARR("A"),-1)
+6 SET DIR("?")="Type a unique sequence number between 1 and 10, 0 Decimal Digits"
+7 IF CNT>0
Begin DoDot:1
+8 NEW LAST
+9 SET DIR("?",1)="CPT MOD SEQ CPT MODIFER"
+10 FOR LOOP=1:1:CNT
Begin DoDot:2
+11 SET DIR("?",LOOP+1)=" "_$PIECE(MODARR(LOOP),U,4)_" "_$SELECT($LENGTH($PIECE(MODARR(LOOP),U,4))=1:" ",1:"")_$PIECE(MODARR(LOOP),U)_" "_$$GET1^DIQ(81.3,$PIECE(MODARR(LOOP),U,2)_",",.02)
End DoDot:2
+12 SET LAST=$ORDER(MODARR("ZZREF2",""),-1)
+13 IF FIRST
IF +LAST
SET DIR("B")=$PIECE(MODARR("ZZREF2",LAST),U,4)
SET FIRST=0
End DoDot:1
+14 ;
+15 SET DIR(0)="FO^1:2"
+16 SET DIR("A")="Select CPT MODIFIER SEQUENCE"
+17 DO ^DIR
+18 if X=""!(X="^")
QUIT
+19 ;
+20 ; quit if ^ or time out ;WCJ;IB742 v15
if $DATA(DIROUT)!$DATA(DTOUT)
QUIT
+21 ; if user entere @ but there was no default, quit because nothing to delete ;WCJ;IB742 v15
if $DATA(DIRUT)&'$GET(DIR("B"))
QUIT
+22 ;
+23 ;WCJ;IB742 v15
+24 ;user entred an @ so they are delting the default
+25 IF $DATA(DIRUT)
Begin DoDot:1
+26 ; rest so it defaults again after deletion
SET FIRST=1
+27 SET X=$GET(DIR("B"))
+28 SET DELETE=1
End DoDot:1
+29 ;
+30 ; an existing exact match on an external modifier so the question is which one.
+31 IF $DATA(MODARR("ZZREF3",X))
Begin DoDot:1
+32 ; grab the first one for now.
SET (DA,Y)=$PIECE(MODARR("ZZREF3",X,$ORDER(MODARR("ZZREF3",X,""))),U,3)
+33 ; check to see if the first/last are the same - quit for now if it isn't
IF $ORDER(MODARR("ZZREF3",X,""))'=$ORDER(MODARR("ZZREF3",X,"A"),-1)
Begin DoDot:2
+34 NEW DIC
+35 SET DIC(0)="EMX"
+36 SET DIC="^DGCR(399,"_DA(1)_",""CP"","_+IBPROCP_",""MOD"","
+37 DO ^DIC
+38 if Y=-1
QUIT
+39 SET DA=+Y
End DoDot:2
if Y=-1
QUIT
+40 ;
+41 SET DA(2)=DA(1)
SET DA(1)=+IBPROCP
+42 SET (DIC,DIE)="^DGCR(399,"_DA(2)_",""CP"",DA(1),""MOD"","
+43 SET DR=".01 CPT MODIFIER SEQUENCE;.02 CPT MODIFIER"
+44 DO ^DIE
End DoDot:1
GOTO AGAIN
+45 ;
+46 ; no exact match and not a whole number so question input and ask again
IF +X'=X!(X>10)!(X<1)!(X?.E1"."1N.N)
Begin DoDot:1
+47 WRITE !,DIR("?"),!
+48 QUIT
End DoDot:1
GOTO AGAIN
+49 ;
+50 ; We have an existing SEQ number (that kind of worked)
+51 IF $DATA(MODARR("ZZREF2",X))
Begin DoDot:1
+52 NEW SEQ
+53 SET SEQ=X
+54 SET DA(2)=DA(1)
SET DA(1)=+IBPROCP
SET (DA,Y)=$PIECE(MODARR("ZZREF2",X),U,3)
+55 SET (DIC,DIE)="^DGCR(399,"_DA(2)_",""CP"",DA(1),""MOD"","
+56 SET DIC(0)="L"
+57 ;WCJ;IB742 v15
SET DR=".01 CPT MODIFIER SEQUENCE"_$SELECT(DELETE:"////@",1:";.02 CPT MODIFER")
+58 DO ^DIE
+59 ;WCJ;IB742 v15
IF DELETE
DO EN^DDIOL("THE ENTIRE '"_SEQ_"' CPT MODIFIER SEQUENCE WAS DELETED")
End DoDot:1
GOTO AGAIN
+60 ;
+61 ; We have a new seq #
+62 IF '$DATA(MODARR("ZZREF2",X))
Begin DoDot:1
+63 SET DLAYGO=399
+64 SET DA(2)=DA(1)
SET DA(1)=+IBPROCP
+65 SET DIC="^DGCR(399,"_DA(2)_",""CP"",DA(1),""MOD"","
+66 SET DIC("DR")=".02"
+67 SET DIC(0)="L"
+68 KILL DD,DO
+69 DO FILE^DICN
End DoDot:1
GOTO AGAIN
+70 ;
+71 QUIT
+72 ;
GETXIST(IBPROCP,MODARR,DA) ; check to see if this code has already been entered as a modifier for this procedure.
+1 ; IN
+2 ; IBPROCP - conatins subfile IEN of which procedure we are working with
+3 ; OUT
+4 ; MODARR - an array with modifier information for this procedure
+5 ;
+6 ; MODARR("ZZREF1",EXTERNAL MODIFIER,CPTSEQNUMBER) = IEN81P3^IENSUBFILE^SEQUENCE NUMBER
+7 ; MODARR("ZZREF2",IEN81P3,CPTSEQNUMBER) = IEN81P3^IENSUBFILE^SEQUENCE NUMBER
+8 ; MODARR("ZZREF3",CPTSEQNUMBER) = IEN81P3^IENSUBFILE^SEQUENCE NUMBER
+9 ; MODARR(COUNT) = IEN81P3^IENSUBFILE^SEQUENCE NUMBER
+10 ;
+11 NEW MOD,MODIEN,MODSFIEN,MODSEQNUM,MODDATA,MODSEQ,I
+12 ;
+13 SET (MOD,MODIEN)=""
+14 FOR
SET MODIEN=$ORDER(^DGCR(399,DA(1),"CP",+IBPROCP,"MOD","C",MODIEN))
if MODIEN=""
QUIT
Begin DoDot:1
+15 SET MOD=$$GET1^DIQ(81.3,MODIEN_",",.01,"E")
+16 ;
+17 SET MODSFIEN=0
+18 FOR
SET MODSFIEN=$ORDER(^DGCR(399,DA(1),"CP",+IBPROCP,"MOD","C",MODIEN,MODSFIEN))
if MODSFIEN=""
QUIT
Begin DoDot:2
+19 SET MODSEQNUM=+$GET(^DGCR(399,DA(1),"CP",+IBPROCP,"MOD",MODSFIEN,0))
+20 SET MODDATA=MOD_U_MODIEN_U_MODSFIEN_U_MODSEQNUM
+21 SET MODARR("ZZREF1",MODIEN,MODSEQNUM)=MODDATA
+22 SET MODARR("ZZREF2",MODSEQNUM)=MODDATA
+23 SET MODARR("ZZREF3",MOD,MODSEQNUM)=MODDATA
End DoDot:2
End DoDot:1
+24 ;
+25 IF $DATA(MODARR)<10
QUIT
+26 ;
+27 ; reorder for display starting with 1
+28 SET MODSEQ=""
FOR I=1:1
SET MODSEQ=$ORDER(MODARR("ZZREF2",MODSEQ))
if MODSEQ=""
QUIT
SET MODARR(I)=MODARR("ZZREF2",MODSEQ)
+29 QUIT
+30 ;
TEST ; amusing myself with alternate methods
+1 ;LIST^DIC(file[,iens][,fields][,flags][,number][,[.]from][,[.]part][,index][,[.]screen][,identifier][,target_root][,msg_root])
+2 DO LIST^DIC(399.30416,,".01;.02","X")
+3 ;
+4 ;FIND^DIC(file[,iens][,fields][,flags],[.]value[,number][,[.]indexes][,[.]screen][,identifier][,target_root][,msg_root])
+5 DO FIND^DIC(399.30416,",1290176,2",".01;.02")
+6 QUIT
