IBDF18A ;ALB/CJM/AAS - ENCOUNTER FORM - utilities for PCE ;12-AUG-94
;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, 1997
;
GLL(CLINIC,INTRFACE,ARY,FILTER) ; -- get lots of lists in one call
; -- input see GETLST but pass interface by reference expects
; intrface(n) = name of select list in package interface file
;
; -- output see GETLST
N X,COUNT
S COUNT=0
S X="" F S X=$O(INTRFACE(X)) Q:X="" D GETLST(CLINIC,INTRFACE(X),ARY,$G(FILTER),.COUNT)
Q
;
GETLST(CLINIC,INTRFACE,ARY,FILTER,COUNT,MODIFIER) ; -- returns any specified selection list for a clinic
; -- input CLINIC = pointer to hospital location file for clinic
; INTRFACE = name of selection list in package interface file
; ARY = name of array to return list in
; FILTER = predefined filters (optional, default = 1)
; 1 = must be selection list
; 2 = only visit cpts on list
; MODIFIER = if modifiers are to be passed, 1=yes send modifiers
;
; -- output The format of the returned array is as follows
; @ARY@(0) = count of array element (0 of nothing found)
; @ARY@(1) = ^group header
; @ARY@(2) = P1 := cpt or icd code / ien of other items
; P2 := user defined text
; p6 := user defined expanded text to send to PCE
; p7 := second code or item defined for line item
; p8 := third code or item defined for line item
; p9 := associated clinical lexicon term
;
; @ARY@(2,"MODIFIER",0)=count of CPT Modifiers for entry
; @ARY@(2,"MODIFIER",1)=2 character CPT Modifier value
; @ARY@(2,"MODIFIER",2)=2 character CPT Modifier value
; @ARY@(2,"MODIFIER",k+1)=2 character CPT Modifier value
;
; @ARY@(k) = ^next group header
; @ARY@(k+1) = problem ien or cpt or icd code^user define text
;
; -- output modification for patch 34:
; Narrative to Send to PCE (instead of printed text)
; field (2.01) in file 357.3, added as piece 6 of @ary@(n)
;
; if additional codes for an item (diagnosis) are added to
; item, they are added as pieces 7 and/or 8 of @ary@(n).
;
; if a type of visit code is requested and none found, will
; automatically look first for blocks named type of visit and
; second for filtered codes using regular cpt blocks.
;
; if a diagnosis block it requested and none found will
; automagically look for Clinic Common Problem List and
; then convert it to look like a diagnosis list
;
N I,J,X,Y,INUM,IBQUIT,FORM,SETUP,LIST,BLOCK,OLDARY,IBDTMP,ROW,COL,BLK
K ^TMP("IBDUP",$J)
S (IBQUIT,LIST)=0
S COUNT=$G(COUNT,0)
I $G(FILTER)<1 S FILTER=1 ;default value=1
I FILTER>1 S OLDARY=ARY,ARY="IBDTMP"
S @ARY@(0)=+$G(@ARY@(0))
I $G(CLINIC)="" G GETLSTQ
I $G(^SC(CLINIC,0))="" G GETLSTQ
I $G(INTRFACE)="" G GETLSTQ
S INUM=$O(^IBE(357.6,"B",$E(INTRFACE,1,30),0))
;
; -- find forms defined for clinic
; piece 2 = basic form
; piece 3,4,6 = supplemental forms
S SETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",CLINIC,0)),0))
G:SETUP="" GETLSTQ
F I=2,3,4,6,8,9 S FORM=$P(SETUP,"^",I) D Q:IBQUIT
.;
.; -- find blocks on forms
.Q:'FORM
. D GETBLKS Q:'$O(BLK(0))
. S (ROW,COL)=""
. F S ROW=$O(BLK(ROW)) Q:ROW="" S COL="" F S COL=$O(BLK(ROW,COL)) Q:COL="" S BLOCK=$G(BLK(+ROW,+COL)) D
..;
..; -- see if package interface defined for blocks
..S LIST=0
..F S LIST=$O(^IBE(357.2,"C",BLOCK,LIST)) Q:'LIST I $P($G(^IBE(357.2,LIST,0)),"^",11)=INUM D COPYLIST^IBDF18A1(LIST,ARY,.COUNT)
;I COUNT D URH^IBDF18A1
S @ARY@(0)=COUNT
I FILTER=2 D F2^IBDF18A1(OLDARY)
;
I COUNT=0 D
.I $E(INTRFACE,1,30)=$E("DG SELECT VISIT TYPE CPT PROCEDURES",1,30) D TOV
;
; -- always check for both diagnosis and clinic common problems when
; looking for diagnosis, return in diagnosis format
I $E(INTRFACE,1,30)=$E("DG SELECT ICD-9 DIAGNOSIS CODES",1,30) D CCP(COUNT)
;
K ^TMP("IBDUP",$J)
;
GETLSTQ Q
;
GETBLKS ; -- get the blocks for a form in row,column order
K BLK
N ROW,COL
S BLK=0
F S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK D
. S ROW=$P($G(^IBE(357.1,+BLK,0)),"^",4),COL=$P(^(0),"^",5)
. Q:ROW=""!(COL="")
. S BLK(ROW,COL)=BLK
Q
;
CCP(COUNT) ; -- no diagnosis, look for common problems and convert
N I,X,OLDCNT
S OLDCNT=COUNT
;
; -- get the clinic common problem list
D GETLST(CLINIC,"GMP SELECT CLINIC COMMON PROBLEMS",ARY,"",COUNT)
;
; -- now convert it to primary icd code save lexicon pointer in piece 6
S I=OLDCNT
F S I=$O(VAR(I)) Q:I="" D
.S X=+VAR(I)
. S:X $P(VAR(I),"^",9)=X,$P(VAR(I),"^",1)=$$ICDONE^LEXU(X)
. I $P(VAR(I),"^",7) S $P(VAR(I),"^",7)=$$ICDONE^LEXU($P(VAR(I),"^",7))
. I $P(VAR(I),"^",8) S $P(VAR(I),"^",8)=$$ICDONE^LEXU($P(VAR(I),"^",8))
Q
;
TOV ; -- if trying to find Type of Visit codes but list on form
; uses another interface try this
;
N INUM
S INUM=0
F S INUM=$O(^IBE(357.6,"B","DG SELECT CPT PROCEDURE CODES",INUM)) Q:'INUM S INUM(INUM)=""
D TOV1
I COUNT=0 D TOV2
Q
;
TOV1 ; -- first get all lists for blocks named Type of Visit or E&M
N NM,HD
F I=2,3,4,6,8,9 S FORM=$P(SETUP,"^",I) D:+FORM Q:IBQUIT
. ;
. ; -- find blocks on forms
. D GETBLKS Q:'$O(BLK(0))
. S (ROW,COL)=""
. F S ROW=$O(BLK(ROW)) Q:ROW="" S COL="" F S COL=$O(BLK(ROW,COL)) Q:COL="" S BLOCK=$G(BLK(+ROW,+COL)) D
.. ;
.. S NM=$P($G(^IBE(357.1,BLOCK,0)),"^",1)
.. S NM=$TR(NM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.. S HD=$P($G(^IBE(357.1,BLOCK,0)),"^",11)
.. S HD=$TR(HD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.. I NM["TYPE OF VISIT"!(NM["VISIT TYPE")!(HD["TYPE OF VISIT")!(HD["VISIT TYPE")!(NM["E&M")!(NM["E & M")!(HD["E&M")!(HD["E & M") D
... S LIST=0
... F S LIST=$O(^IBE(357.2,"C",BLOCK,LIST)) Q:'LIST D
.... I $D(INUM($P($G(^IBE(357.2,LIST,0)),"^",11))) D COPYLIST^IBDF18A1(LIST,ARY,.COUNT) K BLK(ROW,COL)
Q
;
TOV2 ; -- get the type of visit codes from cpt lists using filter
S OLDARY=ARY,ARY="IBDTMP"
S @ARY@(0)=+$G(@ARY@(0))
;
F I=2,3,4,6,8,9 S FORM=$P(SETUP,"^",I) D:+FORM Q:IBQUIT
. ;
. ; -- find blocks on forms
. S (ROW,COL)=""
. F S ROW=$O(BLK(ROW)) Q:ROW="" S COL="" F S COL=$O(BLK(ROW,COL)) Q:COL="" S BLOCK=$G(BLK(+ROW,+COL)) D
.. ;
.. ; -- see if package interface defined for blocks
.. S LIST=0
.. F S LIST=$O(^IBE(357.2,"C",BLOCK,LIST)) Q:'LIST I $D(INUM($P($G(^IBE(357.2,LIST,0)),"^",11))) D COPYLIST^IBDF18A1(LIST,ARY,.COUNT)
D F2^IBDF18A1(OLDARY)
Q
;
; -- here are some sample tests for different lists
TEST1 K VAR D GETLST(573,"DG SELECT ICD-9 DIAGNOSIS CODES","VAR",1)
X "ZW VAR"
Q
;
TEST2 K VAR D GETLST(301,"DG SELECT ICD-9 DIAGNOSIS CODES","VAR",1)
X "ZW VAR"
Q
;
TEST4 K VAR D GETLST(300,"DG SELECT VISIT TYPE CPT PROCEDURES","VAR",1)
X "ZW VAR"
Q
;
TEST5 K VAR D GETLST(300,"PX SELECT IMMUNIZATIONS","VAR",1)
X "ZW VAR"
Q
;
TEST6 K VAR D GETLST(573,"DG SELECT CPT PROCEDURE CODES","VAR",1)
X "ZW VAR"
Q
;
TEST7 K VAR D GETLST(573,"DG SELECT VISIT TYPE CPT PROCEDURES","VAR",1)
X "ZW VAR"
Q
;
TEST8 ; -- use this to test CPRS ability to retrieve type of visit
; set clinic := name or internal entry number of clinic or change
; value for specific clinic
K VAR
I $G(CLINIC)="" S CLINIC=300
I CLINIC'=+CLINIC W !,"Using Clinic: ",CLINIC S CLINIC=$O(^SC("B",CLINIC,0)) W !,"IEN: ",CLINIC,! H 5
X "D VISIT^ORWPCE(.VAR,CLINIC) ZW VAR"
Q
;
TEST9 K VAR D GETLST(301,"GMP SELECT CLINIC COMMON PROBLEMS","VAR",1)
X "ZW VAR"
Q
IBDF18A ;ALB/CJM/AAS - ENCOUNTER FORM - utilities for PCE ;12-AUG-94
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, 1997
+2 ;
GLL(CLINIC,INTRFACE,ARY,FILTER) ; -- get lots of lists in one call
+1 ; -- input see GETLST but pass interface by reference expects
+2 ; intrface(n) = name of select list in package interface file
+3 ;
+4 ; -- output see GETLST
+5 NEW X,COUNT
+6 SET COUNT=0
+7 SET X=""
FOR
SET X=$ORDER(INTRFACE(X))
IF X=""
QUIT
DO GETLST(CLINIC,INTRFACE(X),ARY,$GET(FILTER),.COUNT)
+8 QUIT
+9 ;
GETLST(CLINIC,INTRFACE,ARY,FILTER,COUNT,MODIFIER) ; -- returns any specified selection list for a clinic
+1 ; -- input CLINIC = pointer to hospital location file for clinic
+2 ; INTRFACE = name of selection list in package interface file
+3 ; ARY = name of array to return list in
+4 ; FILTER = predefined filters (optional, default = 1)
+5 ; 1 = must be selection list
+6 ; 2 = only visit cpts on list
+7 ; MODIFIER = if modifiers are to be passed, 1=yes send modifiers
+8 ;
+9 ; -- output The format of the returned array is as follows
+10 ; @ARY@(0) = count of array element (0 of nothing found)
+11 ; @ARY@(1) = ^group header
+12 ; @ARY@(2) = P1 := cpt or icd code / ien of other items
+13 ; P2 := user defined text
+14 ; p6 := user defined expanded text to send to PCE
+15 ; p7 := second code or item defined for line item
+16 ; p8 := third code or item defined for line item
+17 ; p9 := associated clinical lexicon term
+18 ;
+19 ; @ARY@(2,"MODIFIER",0)=count of CPT Modifiers for entry
+20 ; @ARY@(2,"MODIFIER",1)=2 character CPT Modifier value
+21 ; @ARY@(2,"MODIFIER",2)=2 character CPT Modifier value
+22 ; @ARY@(2,"MODIFIER",k+1)=2 character CPT Modifier value
+23 ;
+24 ; @ARY@(k) = ^next group header
+25 ; @ARY@(k+1) = problem ien or cpt or icd code^user define text
+26 ;
+27 ; -- output modification for patch 34:
+28 ; Narrative to Send to PCE (instead of printed text)
+29 ; field (2.01) in file 357.3, added as piece 6 of @ary@(n)
+30 ;
+31 ; if additional codes for an item (diagnosis) are added to
+32 ; item, they are added as pieces 7 and/or 8 of @ary@(n).
+33 ;
+34 ; if a type of visit code is requested and none found, will
+35 ; automatically look first for blocks named type of visit and
+36 ; second for filtered codes using regular cpt blocks.
+37 ;
+38 ; if a diagnosis block it requested and none found will
+39 ; automagically look for Clinic Common Problem List and
+40 ; then convert it to look like a diagnosis list
+41 ;
+42 NEW I,J,X,Y,INUM,IBQUIT,FORM,SETUP,LIST,BLOCK,OLDARY,IBDTMP,ROW,COL,BLK
+43 KILL ^TMP("IBDUP",$JOB)
+44 SET (IBQUIT,LIST)=0
+45 SET COUNT=$GET(COUNT,0)
+46 ;default value=1
IF $GET(FILTER)<1
SET FILTER=1
+47 IF FILTER>1
SET OLDARY=ARY
SET ARY="IBDTMP"
+48 SET @ARY@(0)=+$GET(@ARY@(0))
+49 IF $GET(CLINIC)=""
GOTO GETLSTQ
+50 IF $GET(^SC(CLINIC,0))=""
GOTO GETLSTQ
+51 IF $GET(INTRFACE)=""
GOTO GETLSTQ
+52 SET INUM=$ORDER(^IBE(357.6,"B",$EXTRACT(INTRFACE,1,30),0))
+53 ;
+54 ; -- find forms defined for clinic
+55 ; piece 2 = basic form
+56 ; piece 3,4,6 = supplemental forms
+57 SET SETUP=$GET(^SD(409.95,+$ORDER(^SD(409.95,"B",CLINIC,0)),0))
+58 IF SETUP=""
GOTO GETLSTQ
+59 FOR I=2,3,4,6,8,9
SET FORM=$PIECE(SETUP,"^",I)
Begin DoDot:1
+60 ;
+61 ; -- find blocks on forms
+62 IF 'FORM
QUIT
+63 DO GETBLKS
IF '$ORDER(BLK(0))
QUIT
+64 SET (ROW,COL)=""
+65 FOR
SET ROW=$ORDER(BLK(ROW))
IF ROW=""
QUIT
SET COL=""
FOR
SET COL=$ORDER(BLK(ROW,COL))
IF COL=""
QUIT
SET BLOCK=$GET(BLK(+ROW,+COL))
Begin DoDot:2
+66 ;
+67 ; -- see if package interface defined for blocks
+68 SET LIST=0
+69 FOR
SET LIST=$ORDER(^IBE(357.2,"C",BLOCK,LIST))
IF 'LIST
QUIT
IF $PIECE($GET(^IBE(357.2,LIST,0)),"^",11)=INUM
DO COPYLIST^IBDF18A1(LIST,ARY,.COUNT)
End DoDot:2
End DoDot:1
IF IBQUIT
QUIT
+70 ;I COUNT D URH^IBDF18A1
+71 SET @ARY@(0)=COUNT
+72 IF FILTER=2
DO F2^IBDF18A1(OLDARY)
+73 ;
+74 IF COUNT=0
Begin DoDot:1
+75 IF $EXTRACT(INTRFACE,1,30)=$EXTRACT("DG SELECT VISIT TYPE CPT PROCEDURES",1,30)
DO TOV
End DoDot:1
+76 ;
+77 ; -- always check for both diagnosis and clinic common problems when
+78 ; looking for diagnosis, return in diagnosis format
+79 IF $EXTRACT(INTRFACE,1,30)=$EXTRACT("DG SELECT ICD-9 DIAGNOSIS CODES",1,30)
DO CCP(COUNT)
+80 ;
+81 KILL ^TMP("IBDUP",$JOB)
+82 ;
GETLSTQ QUIT
+1 ;
GETBLKS ; -- get the blocks for a form in row,column order
+1 KILL BLK
+2 NEW ROW,COL
+3 SET BLK=0
+4 FOR
SET BLK=$ORDER(^IBE(357.1,"C",FORM,BLK))
IF 'BLK
QUIT
Begin DoDot:1
+5 SET ROW=$PIECE($GET(^IBE(357.1,+BLK,0)),"^",4)
SET COL=$PIECE(^(0),"^",5)
+6 IF ROW=""!(COL="")
QUIT
+7 SET BLK(ROW,COL)=BLK
End DoDot:1
+8 QUIT
+9 ;
CCP(COUNT) ; -- no diagnosis, look for common problems and convert
+1 NEW I,X,OLDCNT
+2 SET OLDCNT=COUNT
+3 ;
+4 ; -- get the clinic common problem list
+5 DO GETLST(CLINIC,"GMP SELECT CLINIC COMMON PROBLEMS",ARY,"",COUNT)
+6 ;
+7 ; -- now convert it to primary icd code save lexicon pointer in piece 6
+8 SET I=OLDCNT
+9 FOR
SET I=$ORDER(VAR(I))
IF I=""
QUIT
Begin DoDot:1
+10 SET X=+VAR(I)
+11 IF X
SET $PIECE(VAR(I),"^",9)=X
SET $PIECE(VAR(I),"^",1)=$$ICDONE^LEXU(X)
+12 IF $PIECE(VAR(I),"^",7)
SET $PIECE(VAR(I),"^",7)=$$ICDONE^LEXU($PIECE(VAR(I),"^",7))
+13 IF $PIECE(VAR(I),"^",8)
SET $PIECE(VAR(I),"^",8)=$$ICDONE^LEXU($PIECE(VAR(I),"^",8))
End DoDot:1
+14 QUIT
+15 ;
TOV ; -- if trying to find Type of Visit codes but list on form
+1 ; uses another interface try this
+2 ;
+3 NEW INUM
+4 SET INUM=0
+5 FOR
SET INUM=$ORDER(^IBE(357.6,"B","DG SELECT CPT PROCEDURE CODES",INUM))
IF 'INUM
QUIT
SET INUM(INUM)=""
+6 DO TOV1
+7 IF COUNT=0
DO TOV2
+8 QUIT
+9 ;
TOV1 ; -- first get all lists for blocks named Type of Visit or E&M
+1 NEW NM,HD
+2 FOR I=2,3,4,6,8,9
SET FORM=$PIECE(SETUP,"^",I)
IF +FORM
Begin DoDot:1
+3 ;
+4 ; -- find blocks on forms
+5 DO GETBLKS
IF '$ORDER(BLK(0))
QUIT
+6 SET (ROW,COL)=""
+7 FOR
SET ROW=$ORDER(BLK(ROW))
IF ROW=""
QUIT
SET COL=""
FOR
SET COL=$ORDER(BLK(ROW,COL))
IF COL=""
QUIT
SET BLOCK=$GET(BLK(+ROW,+COL))
Begin DoDot:2
+8 ;
+9 SET NM=$PIECE($GET(^IBE(357.1,BLOCK,0)),"^",1)
+10 SET NM=$TRANSLATE(NM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+11 SET HD=$PIECE($GET(^IBE(357.1,BLOCK,0)),"^",11)
+12 SET HD=$TRANSLATE(HD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+13 IF NM["TYPE OF VISIT"!(NM["VISIT TYPE")!(HD["TYPE OF VISIT")!(HD["VISIT TYPE")!(NM["E&M")!(NM["E & M")!(HD["E&M")!(HD["E & M")
Begin DoDot:3
+14 SET LIST=0
+15 FOR
SET LIST=$ORDER(^IBE(357.2,"C",BLOCK,LIST))
IF 'LIST
QUIT
Begin DoDot:4
+16 IF $DATA(INUM($PIECE($GET(^IBE(357.2,LIST,0)),"^",11)))
DO COPYLIST^IBDF18A1(LIST,ARY,.COUNT)
KILL BLK(ROW,COL)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
IF IBQUIT
QUIT
+17 QUIT
+18 ;
TOV2 ; -- get the type of visit codes from cpt lists using filter
+1 SET OLDARY=ARY
SET ARY="IBDTMP"
+2 SET @ARY@(0)=+$GET(@ARY@(0))
+3 ;
+4 FOR I=2,3,4,6,8,9
SET FORM=$PIECE(SETUP,"^",I)
IF +FORM
Begin DoDot:1
+5 ;
+6 ; -- find blocks on forms
+7 SET (ROW,COL)=""
+8 FOR
SET ROW=$ORDER(BLK(ROW))
IF ROW=""
QUIT
SET COL=""
FOR
SET COL=$ORDER(BLK(ROW,COL))
IF COL=""
QUIT
SET BLOCK=$GET(BLK(+ROW,+COL))
Begin DoDot:2
+9 ;
+10 ; -- see if package interface defined for blocks
+11 SET LIST=0
+12 FOR
SET LIST=$ORDER(^IBE(357.2,"C",BLOCK,LIST))
IF 'LIST
QUIT
IF $DATA(INUM($PIECE($GET(^IBE(357.2,LIST,0)),"^",11)))
DO COPYLIST^IBDF18A1(LIST,ARY,.COUNT)
End DoDot:2
End DoDot:1
IF IBQUIT
QUIT
+13 DO F2^IBDF18A1(OLDARY)
+14 QUIT
+15 ;
+16 ; -- here are some sample tests for different lists
TEST1 KILL VAR
DO GETLST(573,"DG SELECT ICD-9 DIAGNOSIS CODES","VAR",1)
+1 XECUTE "ZW VAR"
+2 QUIT
+3 ;
TEST2 KILL VAR
DO GETLST(301,"DG SELECT ICD-9 DIAGNOSIS CODES","VAR",1)
+1 XECUTE "ZW VAR"
+2 QUIT
+3 ;
TEST4 KILL VAR
DO GETLST(300,"DG SELECT VISIT TYPE CPT PROCEDURES","VAR",1)
+1 XECUTE "ZW VAR"
+2 QUIT
+3 ;
TEST5 KILL VAR
DO GETLST(300,"PX SELECT IMMUNIZATIONS","VAR",1)
+1 XECUTE "ZW VAR"
+2 QUIT
+3 ;
TEST6 KILL VAR
DO GETLST(573,"DG SELECT CPT PROCEDURE CODES","VAR",1)
+1 XECUTE "ZW VAR"
+2 QUIT
+3 ;
TEST7 KILL VAR
DO GETLST(573,"DG SELECT VISIT TYPE CPT PROCEDURES","VAR",1)
+1 XECUTE "ZW VAR"
+2 QUIT
+3 ;
TEST8 ; -- use this to test CPRS ability to retrieve type of visit
+1 ; set clinic := name or internal entry number of clinic or change
+2 ; value for specific clinic
+3 KILL VAR
+4 IF $GET(CLINIC)=""
SET CLINIC=300
+5 IF CLINIC'=+CLINIC
WRITE !,"Using Clinic: ",CLINIC
SET CLINIC=$ORDER(^SC("B",CLINIC,0))
WRITE !,"IEN: ",CLINIC,!
HANG 5
+6 XECUTE "D VISIT^ORWPCE(.VAR,CLINIC) ZW VAR"
+7 QUIT
+8 ;
TEST9 KILL VAR
DO GETLST(301,"GMP SELECT CLINIC COMMON PROBLEMS","VAR",1)
+1 XECUTE "ZW VAR"
+2 QUIT
