source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF17.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1IBDF17 ;ALB/CJM - ENCOUNTER FORM - COPY A CPT CHECK-OFF SHEET INTO A FORM ;24SEP93
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
3 ;DHH
4 ;Allows the user to choose a form to copy to, and a CPT check-off sheet
5 ;to copy from, then creates a new block and copies the CPT codes to it
6 ;
7 N FORM,LIST,BLOCK,SHEET
8 W !!,"Select the encounter form you want to copy CPT codes to!",!
9 S FORM=$$SLCTFORM^IBDFU4(0)
10 Q:'FORM
11 D FIND(FORM,.BLOCK,.LIST)
12 I 'BLOCK W !,"There is no selection list for CPT codes to copy to!" D PAUSE^IBDFU5 Q
13 ;
14 S SHEET=$$SLCTSHT
15 Q:'SHEET
16 ;
17 ;must delete the compiled version of the block, since it will be changed
18 K ^IBE(357.1,BLOCK,"S"),^("V"),^("B"),^("H")
19 ;
20 D COPY(SHEET,LIST)
21 Q
22 ;
23COPY(SHEET,LIST) ;copies the CPT codes/headers from the sheet to the list
24 ;
25 N HDR,TYPE,NODE
26 ;
27 ;find the subcolumns in LIST to write to
28 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
29 ;
30 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)
31 Q
32 ;
33COPYGRP(HDR,NODE,LIST) ;copies the header contained in NODE to the selection list (LIST)
34 ;
35 N HEADER,ORDER,GROUP,PROC
36 S HEADER=$P(NODE,"^") Q:HEADER="" S ORDER=$P(NODE,"^",2) Q:'ORDER
37 ;
38 ;copy the group
39 K DIC,DD,D0,DINUM S DIC="^IBE(357.4,",X=HEADER,DIC(0)=""
40 D FILE^DICN K DIC,DIE,DA
41 S GROUP=$S(+Y<0:"",1:+Y)
42 Q:'GROUP
43 S ^IBE(357.4,GROUP,0)=HEADER_"^"_ORDER_"^"_LIST
44 K DIK,DA S DIK="^IBE(357.4,",DA=GROUP
45 D IX1^DIK K DIK,DA
46 ;
47 ;now find all the group's procedures and copy them
48 S PROC=0 F S PROC=$O(^IBE(350.71,"S",HDR,PROC)) Q:'PROC D:PROC'=HDR COPYPROC(PROC,.LIST,GROUP)
49 ;
50 W "." ;just to let the use know it's doing something
51 Q
52 ;
53COPYPROC(PROC,LIST,GROUP) ;copies the procedure contained to the selection list and group
54 ;
55 N NODE,TEXT,ORDER,CODE,SLCTN
56 S NODE=$G(^IBE(350.71,PROC,0))
57 ;
58 ;find the CPT code
59 S CODE=$P(NODE,"^",6)
60 Q:'CODE
61 S CODE=$P($G(^SD(409.71,CODE,0)),"^")
62 Q:'CODE
63 ;; --change to api cpt ; dhh
64 S CODE=$$CPT^ICPTCOD(CODE)
65 Q:+CODE=-1
66 S CODE=$P(CODE,"^",2)
67 Q:'CODE
68 ;
69 ;find the text and order for the proc on the sheet
70 S TEXT=$P(NODE,"^") Q:TEXT="" S ORDER=$P(NODE,"^",2) Q:'ORDER
71 ;
72 ;create the selection
73 K DIC,DD,D0,DINUM S DIC="^IBE(357.3,",X=CODE,DIC(0)=""
74 D FILE^DICN K DIC,DIE,DA
75 S SLCTN=$S(+Y<0:"",1:+Y)
76 Q:'SLCTN
77 ;
78 ;fill in the 0 node
79 S ^IBE(357.3,SLCTN,0)=CODE_"^^"_LIST_"^"_GROUP_"^"_ORDER_"^"
80 ;
81 ;fill in the SUBCOLUM VALUE multiple with the subcolumn values
82 S ^IBE(357.3,SLCTN,1,0)="^357.31IA^2^2"
83 S ^IBE(357.3,SLCTN,1,2,0)=LIST("TEXTSC")_"^"_TEXT
84 S ^IBE(357.3,SLCTN,1,1,0)=LIST("CODESC")_"^"_CODE
85 K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN
86 D IX1^DIK K DIK,DA
87 Q
88 ;
89SUBCOLS(LIST) ;finds the column containing the CPT code and the text description
90 ;LIST is passed by reference
91 S (LIST("CODESC"),LIST("TEXTSC"))=""
92 ;
93 N SC,PIECE,NODE S SC=0
94 ;
95 ;piece 1 of the data returned by the package interface is the code,piece 2 is the description
96 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")
97 Q
98 ;
99SLCTSHT() ;allows the user to select a CPT check-off sheet
100 K DIC S DIC=350.7,DIC(0)="AEMQ" D ^DIC K DIC
101 I $D(DINUM)!$D(DUOUT)!(Y<0) Q ""
102 Q +Y
103FIND(FORM,BLK,LIST) ;finds the block & list for CPT codes
104 N INTRFACE,BLOCKS,I
105 S (BLK,LIST,BLOCKS,I)=0
106 ;
107 ;find the package interface for selecting CPT codes
108 S INTRFACE=$O(^IBE(357.6,"B","DG SELECT CPT PROCEDURE CODES",0))
109 Q:'INTRFACE
110 ;
111 ;find all of the blocks with CPT lists
112 S BLK="" F S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK D
113 .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
114 ;
115 ;if count of blocks <2 there is no need to ask the user to choose
116 I BLOCKS<2 S BLK=+$P($G(BLOCKS(1)),"^"),LIST=$P($G(BLOCKS(1)),"^",2) Q
117 ;
118 ;if count>1 the user must choose the block from the array BLOCKS
119 S (BLK,LIST)=0
120 S I=$$CHOOSE(.BLOCKS)
121 S BLK=+$G(BLOCKS(+I)),LIST=+$P($G(BLOCKS(+I)),"^",2)
122 Q
123 ;
124CHOOSE(BLOCKS) ;ask the user to choose
125 ;BLOCKS is an array passed by reference
126 ;
127 N I
128ASK W ! S I=0 F S I=$O(BLOCKS(I)) Q:'I W !,I," ",$P($G(^IBE(357.1,+BLOCKS(I),0)),"^")
129 W !!,"Select a block to put the CPT codes: (1-",BLOCKS,"): "
130 R I:DTIME
131 Q:'$T 0
132 Q:'$G(I) 0
133 I '$D(BLOCKS(I)) G ASK
134 Q I
Note: See TracBrowser for help on using the repository browser.