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

IBDF17.m

Go to the documentation of this file. 
  1. 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
  1.  ;DHH
  1.  ;Allows the user to choose a form to copy to, and a CPT check-off sheet
  1.  ;to copy from, then creates a new block and copies the CPT codes to it
  1.  ;
  1.  N FORM,LIST,BLOCK,SHEET
  1.  W !!,"Select the encounter form you want to copy CPT codes to!",!
  1.  S FORM=$$SLCTFORM^IBDFU4(0)
  1.  Q:'FORM
  1.  D FIND(FORM,.BLOCK,.LIST)
  1.  I 'BLOCK W !,"There is no selection list for CPT codes to copy to!" D PAUSE^IBDFU5 Q
  1.  ;
  1.  S SHEET=$$SLCTSHT
  1.  Q:'SHEET
  1.  ;
  1.  ;must delete the compiled version of the block, since it will be changed
  1.  K ^IBE(357.1,BLOCK,"S"),^("V"),^("B"),^("H")
  1.  ;
  1.  D COPY(SHEET,LIST)
  1.  Q
  1.  ;
  1. COPY(SHEET,LIST) ;copies the CPT codes/headers from the sheet to the list
  1.  ;
  1.  N HDR,TYPE,NODE
  1.  ;
  1.  ;find the subcolumns in LIST to write to
  1.  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
  1.  ;
  1.  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)
  1.  Q
  1.  ;
  1. COPYGRP(HDR,NODE,LIST) ;copies the header contained in NODE to the selection list (LIST)
  1.  ;
  1.  N HEADER,ORDER,GROUP,PROC
  1.  S HEADER=$P(NODE,"^") Q:HEADER=""  S ORDER=$P(NODE,"^",2) Q:'ORDER
  1.  ;
  1.  ;copy the group
  1.  K DIC,DD,D0,DINUM S DIC="^IBE(357.4,",X=HEADER,DIC(0)=""
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S GROUP=$S(+Y<0:"",1:+Y)
  1.  Q:'GROUP
  1.  S ^IBE(357.4,GROUP,0)=HEADER_"^"_ORDER_"^"_LIST
  1.  K DIK,DA S DIK="^IBE(357.4,",DA=GROUP
  1.  D IX1^DIK K DIK,DA
  1.  ;
  1.  ;now find all the group's procedures and copy them
  1.  S PROC=0 F  S PROC=$O(^IBE(350.71,"S",HDR,PROC)) Q:'PROC  D:PROC'=HDR COPYPROC(PROC,.LIST,GROUP)
  1.  ;
  1.  W "." ;just to let the use know it's doing something
  1.  Q
  1.  ;
  1. COPYPROC(PROC,LIST,GROUP) ;copies the procedure contained to the selection list and group
  1.  ;
  1.  N NODE,TEXT,ORDER,CODE,SLCTN
  1.  S NODE=$G(^IBE(350.71,PROC,0))
  1.  ;
  1.  ;find the CPT code
  1.  S CODE=$P(NODE,"^",6)
  1.  Q:'CODE
  1.  S CODE=$P($G(^SD(409.71,CODE,0)),"^")
  1.  Q:'CODE
  1.  ;; --change to api cpt ; dhh
  1.  S CODE=$$CPT^ICPTCOD(CODE)
  1.  Q:+CODE=-1
  1.  S CODE=$P(CODE,"^",2)
  1.  Q:'CODE
  1.  ;
  1.  ;find the text and order for the proc on the sheet
  1.  S TEXT=$P(NODE,"^") Q:TEXT=""  S ORDER=$P(NODE,"^",2) Q:'ORDER
  1.  ;
  1.  ;create the selection
  1.  K DIC,DD,D0,DINUM S DIC="^IBE(357.3,",X=CODE,DIC(0)=""
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S SLCTN=$S(+Y<0:"",1:+Y)
  1.  Q:'SLCTN
  1.  ;
  1.  ;fill in the 0 node
  1.  S ^IBE(357.3,SLCTN,0)=CODE_"^^"_LIST_"^"_GROUP_"^"_ORDER_"^"
  1.  ;
  1.  ;fill in the SUBCOLUM VALUE multiple with the subcolumn values
  1.  S ^IBE(357.3,SLCTN,1,0)="^357.31IA^2^2"
  1.  S ^IBE(357.3,SLCTN,1,2,0)=LIST("TEXTSC")_"^"_TEXT
  1.  S ^IBE(357.3,SLCTN,1,1,0)=LIST("CODESC")_"^"_CODE
  1.  K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN
  1.  D IX1^DIK K DIK,DA
  1.  Q
  1.  ;
  1. SUBCOLS(LIST) ;finds the column containing the CPT code and the text description
  1.  ;LIST is passed by reference
  1.  S (LIST("CODESC"),LIST("TEXTSC"))=""
  1.  ;
  1.  N SC,PIECE,NODE S SC=0
  1.  ;
  1.  ;piece 1 of the data returned by the package interface is the code,piece 2 is the description
  1.  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")
  1.  Q
  1.  ;
  1. SLCTSHT() ;allows the user to select a CPT check-off sheet
  1.  K DIC S DIC=350.7,DIC(0)="AEMQ" D ^DIC K DIC
  1.  I $D(DINUM)!$D(DUOUT)!(Y<0) Q ""
  1.  Q +Y
  1. FIND(FORM,BLK,LIST) ;finds the block & list for CPT codes
  1.  N INTRFACE,BLOCKS,I
  1.  S (BLK,LIST,BLOCKS,I)=0
  1.  ;
  1.  ;find the package interface for selecting CPT codes
  1.  S INTRFACE=$O(^IBE(357.6,"B","DG SELECT CPT PROCEDURE CODES",0))
  1.  Q:'INTRFACE
  1.  ;
  1.  ;find all of the blocks with CPT lists
  1.  S BLK="" F  S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK  D
  1.  .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
  1.  ;
  1.  ;if count of blocks <2 there is no need to ask the user to choose
  1.  I BLOCKS<2 S BLK=+$P($G(BLOCKS(1)),"^"),LIST=$P($G(BLOCKS(1)),"^",2) Q
  1.  ;
  1.  ;if count>1 the user must choose the block from the array BLOCKS
  1.  S (BLK,LIST)=0
  1.  S I=$$CHOOSE(.BLOCKS)
  1.  S BLK=+$G(BLOCKS(+I)),LIST=+$P($G(BLOCKS(+I)),"^",2)
  1.  Q
  1.  ;
  1. CHOOSE(BLOCKS) ;ask the user to choose
  1.  ;BLOCKS is an array passed by reference
  1.  ;
  1.  N I
  1. ASK W ! S I=0 F  S I=$O(BLOCKS(I)) Q:'I  W !,I,"  ",$P($G(^IBE(357.1,+BLOCKS(I),0)),"^")
  1.  W !!,"Select a block to put the CPT codes: (1-",BLOCKS,"): "
  1.  R I:DTIME
  1.  Q:'$T 0
  1.  Q:'$G(I) 0
  1.  I '$D(BLOCKS(I)) G ASK
  1.  Q I