IBDF17 ;ALB/CJM - ENCOUNTER FORM - COPY A CPT CHECK-OFF SHEET INTO A FORM ;24SEP93
;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
;DHH
;Allows the user to choose a form to copy to, and a CPT check-off sheet
;to copy from, then creates a new block and copies the CPT codes to it
;
N FORM,LIST,BLOCK,SHEET
W !!,"Select the encounter form you want to copy CPT codes to!",!
S FORM=$$SLCTFORM^IBDFU4(0)
Q:'FORM
D FIND(FORM,.BLOCK,.LIST)
I 'BLOCK W !,"There is no selection list for CPT codes to copy to!" D PAUSE^IBDFU5 Q
;
S SHEET=$$SLCTSHT
Q:'SHEET
;
;must delete the compiled version of the block, since it will be changed
K ^IBE(357.1,BLOCK,"S"),^("V"),^("B"),^("H")
;
D COPY(SHEET,LIST)
Q
;
COPY(SHEET,LIST) ;copies the CPT codes/headers from the sheet to the list
;
N HDR,TYPE,NODE
;
;find the subcolumns in LIST to write to
D SUBCOLS(.LIST) I 'LIST("CODESC")!'LIST("TEXTSC") W !,"The CPT selection list does not contain a subcolumn for the CPT code or text!" D PAUSE^IBDFU5 Q
;
S HDR="" F S HDR=$O(^IBE(350.71,"G",SHEET,HDR)) Q:'HDR S NODE=$G(^IBE(350.71,HDR,0)),TYPE=$P(NODE,"^",3) D:TYPE="S" COPYGRP(HDR,.NODE,.LIST)
Q
;
COPYGRP(HDR,NODE,LIST) ;copies the header contained in NODE to the selection list (LIST)
;
N HEADER,ORDER,GROUP,PROC
S HEADER=$P(NODE,"^") Q:HEADER="" S ORDER=$P(NODE,"^",2) Q:'ORDER
;
;copy the group
K DIC,DD,D0,DINUM S DIC="^IBE(357.4,",X=HEADER,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S GROUP=$S(+Y<0:"",1:+Y)
Q:'GROUP
S ^IBE(357.4,GROUP,0)=HEADER_"^"_ORDER_"^"_LIST
K DIK,DA S DIK="^IBE(357.4,",DA=GROUP
D IX1^DIK K DIK,DA
;
;now find all the group's procedures and copy them
S PROC=0 F S PROC=$O(^IBE(350.71,"S",HDR,PROC)) Q:'PROC D:PROC'=HDR COPYPROC(PROC,.LIST,GROUP)
;
W "." ;just to let the use know it's doing something
Q
;
COPYPROC(PROC,LIST,GROUP) ;copies the procedure contained to the selection list and group
;
N NODE,TEXT,ORDER,CODE,SLCTN
S NODE=$G(^IBE(350.71,PROC,0))
;
;find the CPT code
S CODE=$P(NODE,"^",6)
Q:'CODE
S CODE=$P($G(^SD(409.71,CODE,0)),"^")
Q:'CODE
;; --change to api cpt ; dhh
S CODE=$$CPT^ICPTCOD(CODE)
Q:+CODE=-1
S CODE=$P(CODE,"^",2)
Q:'CODE
;
;find the text and order for the proc on the sheet
S TEXT=$P(NODE,"^") Q:TEXT="" S ORDER=$P(NODE,"^",2) Q:'ORDER
;
;create the selection
K DIC,DD,D0,DINUM S DIC="^IBE(357.3,",X=CODE,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S SLCTN=$S(+Y<0:"",1:+Y)
Q:'SLCTN
;
;fill in the 0 node
S ^IBE(357.3,SLCTN,0)=CODE_"^^"_LIST_"^"_GROUP_"^"_ORDER_"^"
;
;fill in the SUBCOLUM VALUE multiple with the subcolumn values
S ^IBE(357.3,SLCTN,1,0)="^357.31IA^2^2"
S ^IBE(357.3,SLCTN,1,2,0)=LIST("TEXTSC")_"^"_TEXT
S ^IBE(357.3,SLCTN,1,1,0)=LIST("CODESC")_"^"_CODE
K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN
D IX1^DIK K DIK,DA
Q
;
SUBCOLS(LIST) ;finds the column containing the CPT code and the text description
;LIST is passed by reference
S (LIST("CODESC"),LIST("TEXTSC"))=""
;
N SC,PIECE,NODE S SC=0
;
;piece 1 of the data returned by the package interface is the code,piece 2 is the description
F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC S NODE=$G(^IBE(357.2,LIST,2,SC,0)),PIECE=$P(NODE,"^",5) S:PIECE=1 LIST("CODESC")=$P(NODE,"^") S:PIECE=2 LIST("TEXTSC")=$P(NODE,"^") Q:LIST("CODESC")&LIST("TEXTSC")
Q
;
SLCTSHT() ;allows the user to select a CPT check-off sheet
K DIC S DIC=350.7,DIC(0)="AEMQ" D ^DIC K DIC
I $D(DINUM)!$D(DUOUT)!(Y<0) Q ""
Q +Y
FIND(FORM,BLK,LIST) ;finds the block & list for CPT codes
N INTRFACE,BLOCKS,I
S (BLK,LIST,BLOCKS,I)=0
;
;find the package interface for selecting CPT codes
S INTRFACE=$O(^IBE(357.6,"B","DG SELECT CPT PROCEDURE CODES",0))
Q:'INTRFACE
;
;find all of the blocks with CPT lists
S BLK="" F S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK D
.S LIST="" F S LIST=$O(^IBE(357.2,"C",BLK,LIST)) Q:'LIST I $P($G(^IBE(357.2,LIST,0)),"^",11)=INTRFACE S BLOCKS=BLOCKS+1,I=I+1,BLOCKS(I)=BLK_"^"_LIST
;
;if count of blocks <2 there is no need to ask the user to choose
I BLOCKS<2 S BLK=+$P($G(BLOCKS(1)),"^"),LIST=$P($G(BLOCKS(1)),"^",2) Q
;
;if count>1 the user must choose the block from the array BLOCKS
S (BLK,LIST)=0
S I=$$CHOOSE(.BLOCKS)
S BLK=+$G(BLOCKS(+I)),LIST=+$P($G(BLOCKS(+I)),"^",2)
Q
;
CHOOSE(BLOCKS) ;ask the user to choose
;BLOCKS is an array passed by reference
;
N I
ASK W ! S I=0 F S I=$O(BLOCKS(I)) Q:'I W !,I," ",$P($G(^IBE(357.1,+BLOCKS(I),0)),"^")
W !!,"Select a block to put the CPT codes: (1-",BLOCKS,"): "
R I:DTIME
Q:'$T 0
Q:'$G(I) 0
I '$D(BLOCKS(I)) G ASK
Q I
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF17 4669 printed Dec 13, 2024@02:50:48 Page 2
IBDF17 ;ALB/CJM - ENCOUNTER FORM - COPY A CPT CHECK-OFF SHEET INTO A FORM ;24SEP93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
+2 ;DHH
+3 ;Allows the user to choose a form to copy to, and a CPT check-off sheet
+4 ;to copy from, then creates a new block and copies the CPT codes to it
+5 ;
+6 NEW FORM,LIST,BLOCK,SHEET
+7 WRITE !!,"Select the encounter form you want to copy CPT codes to!",!
+8 SET FORM=$$SLCTFORM^IBDFU4(0)
+9 if 'FORM
QUIT
+10 DO FIND(FORM,.BLOCK,.LIST)
+11 IF 'BLOCK
WRITE !,"There is no selection list for CPT codes to copy to!"
DO PAUSE^IBDFU5
QUIT
+12 ;
+13 SET SHEET=$$SLCTSHT
+14 if 'SHEET
QUIT
+15 ;
+16 ;must delete the compiled version of the block, since it will be changed
+17 KILL ^IBE(357.1,BLOCK,"S"),^("V"),^("B"),^("H")
+18 ;
+19 DO COPY(SHEET,LIST)
+20 QUIT
+21 ;
COPY(SHEET,LIST) ;copies the CPT codes/headers from the sheet to the list
+1 ;
+2 NEW HDR,TYPE,NODE
+3 ;
+4 ;find the subcolumns in LIST to write to
+5 DO SUBCOLS(.LIST)
IF 'LIST("CODESC")!'LIST("TEXTSC")
WRITE !,"The CPT selection list does not contain a subcolumn for the CPT code or text!"
DO PAUSE^IBDFU5
QUIT
+6 ;
+7 SET HDR=""
FOR
SET HDR=$ORDER(^IBE(350.71,"G",SHEET,HDR))
if 'HDR
QUIT
SET NODE=$GET(^IBE(350.71,HDR,0))
SET TYPE=$PIECE(NODE,"^",3)
if TYPE="S"
DO COPYGRP(HDR,.NODE,.LIST)
+8 QUIT
+9 ;
COPYGRP(HDR,NODE,LIST) ;copies the header contained in NODE to the selection list (LIST)
+1 ;
+2 NEW HEADER,ORDER,GROUP,PROC
+3 SET HEADER=$PIECE(NODE,"^")
if HEADER=""
QUIT
SET ORDER=$PIECE(NODE,"^",2)
if 'ORDER
QUIT
+4 ;
+5 ;copy the group
+6 KILL DIC,DD,D0,DINUM
SET DIC="^IBE(357.4,"
SET X=HEADER
SET DIC(0)=""
+7 DO FILE^DICN
KILL DIC,DIE,DA
+8 SET GROUP=$SELECT(+Y<0:"",1:+Y)
+9 if 'GROUP
QUIT
+10 SET ^IBE(357.4,GROUP,0)=HEADER_"^"_ORDER_"^"_LIST
+11 KILL DIK,DA
SET DIK="^IBE(357.4,"
SET DA=GROUP
+12 DO IX1^DIK
KILL DIK,DA
+13 ;
+14 ;now find all the group's procedures and copy them
+15 SET PROC=0
FOR
SET PROC=$ORDER(^IBE(350.71,"S",HDR,PROC))
if 'PROC
QUIT
if PROC'=HDR
DO COPYPROC(PROC,.LIST,GROUP)
+16 ;
+17 ;just to let the use know it's doing something
WRITE "."
+18 QUIT
+19 ;
COPYPROC(PROC,LIST,GROUP) ;copies the procedure contained to the selection list and group
+1 ;
+2 NEW NODE,TEXT,ORDER,CODE,SLCTN
+3 SET NODE=$GET(^IBE(350.71,PROC,0))
+4 ;
+5 ;find the CPT code
+6 SET CODE=$PIECE(NODE,"^",6)
+7 if 'CODE
QUIT
+8 SET CODE=$PIECE($GET(^SD(409.71,CODE,0)),"^")
+9 if 'CODE
QUIT
+10 ;; --change to api cpt ; dhh
+11 SET CODE=$$CPT^ICPTCOD(CODE)
+12 if +CODE=-1
QUIT
+13 SET CODE=$PIECE(CODE,"^",2)
+14 if 'CODE
QUIT
+15 ;
+16 ;find the text and order for the proc on the sheet
+17 SET TEXT=$PIECE(NODE,"^")
if TEXT=""
QUIT
SET ORDER=$PIECE(NODE,"^",2)
if 'ORDER
QUIT
+18 ;
+19 ;create the selection
+20 KILL DIC,DD,D0,DINUM
SET DIC="^IBE(357.3,"
SET X=CODE
SET DIC(0)=""
+21 DO FILE^DICN
KILL DIC,DIE,DA
+22 SET SLCTN=$SELECT(+Y<0:"",1:+Y)
+23 if 'SLCTN
QUIT
+24 ;
+25 ;fill in the 0 node
+26 SET ^IBE(357.3,SLCTN,0)=CODE_"^^"_LIST_"^"_GROUP_"^"_ORDER_"^"
+27 ;
+28 ;fill in the SUBCOLUM VALUE multiple with the subcolumn values
+29 SET ^IBE(357.3,SLCTN,1,0)="^357.31IA^2^2"
+30 SET ^IBE(357.3,SLCTN,1,2,0)=LIST("TEXTSC")_"^"_TEXT
+31 SET ^IBE(357.3,SLCTN,1,1,0)=LIST("CODESC")_"^"_CODE
+32 KILL DIK,DA
SET DIK="^IBE(357.3,"
SET DA=SLCTN
+33 DO IX1^DIK
KILL DIK,DA
+34 QUIT
+35 ;
SUBCOLS(LIST) ;finds the column containing the CPT code and the text description
+1 ;LIST is passed by reference
+2 SET (LIST("CODESC"),LIST("TEXTSC"))=""
+3 ;
+4 NEW SC,PIECE,NODE
SET SC=0
+5 ;
+6 ;piece 1 of the data returned by the package interface is the code,piece 2 is the description
+7 FOR
SET SC=$ORDER(^IBE(357.2,LIST,2,SC))
if 'SC
QUIT
SET NODE=$GET(^IBE(357.2,LIST,2,SC,0))
SET PIECE=$PIECE(NODE,"^",5)
if PIECE=1
SET LIST("CODESC")=$PIECE(NODE,"^")
if PIECE=2
SET LIST("TEXTSC")=$PIECE(NODE,"^")
if LIST("CODESC")&LIST("TEXTSC")
QUIT
+8 QUIT
+9 ;
SLCTSHT() ;allows the user to select a CPT check-off sheet
+1 KILL DIC
SET DIC=350.7
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+2 IF $DATA(DINUM)!$DATA(DUOUT)!(Y<0)
QUIT ""
+3 QUIT +Y
FIND(FORM,BLK,LIST) ;finds the block & list for CPT codes
+1 NEW INTRFACE,BLOCKS,I
+2 SET (BLK,LIST,BLOCKS,I)=0
+3 ;
+4 ;find the package interface for selecting CPT codes
+5 SET INTRFACE=$ORDER(^IBE(357.6,"B","DG SELECT CPT PROCEDURE CODES",0))
+6 if 'INTRFACE
QUIT
+7 ;
+8 ;find all of the blocks with CPT lists
+9 SET BLK=""
FOR
SET BLK=$ORDER(^IBE(357.1,"C",FORM,BLK))
if 'BLK
QUIT
Begin DoDot:1
+10 SET LIST=""
FOR
SET LIST=$ORDER(^IBE(357.2,"C",BLK,LIST))
if 'LIST
QUIT
IF $PIECE($GET(^IBE(357.2,LIST,0)),"^",11)=INTRFACE
SET BLOCKS=BLOCKS+1
SET I=I+1
SET BLOCKS(I)=BLK_"^"_LIST
End DoDot:1
+11 ;
+12 ;if count of blocks <2 there is no need to ask the user to choose
+13 IF BLOCKS<2
SET BLK=+$PIECE($GET(BLOCKS(1)),"^")
SET LIST=$PIECE($GET(BLOCKS(1)),"^",2)
QUIT
+14 ;
+15 ;if count>1 the user must choose the block from the array BLOCKS
+16 SET (BLK,LIST)=0
+17 SET I=$$CHOOSE(.BLOCKS)
+18 SET BLK=+$GET(BLOCKS(+I))
SET LIST=+$PIECE($GET(BLOCKS(+I)),"^",2)
+19 QUIT
+20 ;
CHOOSE(BLOCKS) ;ask the user to choose
+1 ;BLOCKS is an array passed by reference
+2 ;
+3 NEW I
ASK WRITE !
SET I=0
FOR
SET I=$ORDER(BLOCKS(I))
if 'I
QUIT
WRITE !,I," ",$PIECE($GET(^IBE(357.1,+BLOCKS(I),0)),"^")
+1 WRITE !!,"Select a block to put the CPT codes: (1-",BLOCKS,"): "
+2 READ I:DTIME
+3 if '$TEST
QUIT 0
+4 if '$GET(I)
QUIT 0
+5 IF '$DATA(BLOCKS(I))
GOTO ASK
+6 QUIT I
