IBDFU1B ;ALB/CJM - ENCOUNTER FORM ;11/16/92
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
;utilities
BLKDESCR(IBBLK) ;parses the block record pointed to by IBBLK and puts the
;description in IBBLK array - should be called by reference
;returns 1 if block description is too incomplete to print block
Q:'$G(IBBLK) 1
N NODE0
S NODE0=$G(^IBE(357.1,IBBLK,0))
S IBBLK("NAME")=$P(NODE0,"^",1)
S IBBLK("Y")=$P(NODE0,"^",4)
S IBBLK("X")=$P(NODE0,"^",5)
S IBBLK("W")=$P(NODE0,"^",6)
S IBBLK("H")=$P(NODE0,"^",7)
S IBBLK("BOX")=$P(NODE0,"^",10)
S IBBLK("HDR")=$P(NODE0,"^",11)
S IBBLK("HDISP")=$P(NODE0,"^",12)
S IBBLK("S")=$P(NODE0,"^",3)
S IBBLK("PAGE")=1+(IBBLK("Y")\IBFORM("PAGE_HT"))
Q:NODE0="" 1
Q 0
;
RTNDSCR(RTN) ;RTN should be a pointer to the Package Interface file
;RTN should be passed by reference
;
N NODE
S NODE="",RTN=+$G(RTN)
S:RTN NODE=$G(^IBE(357.6,RTN,0))
S RTN("ACTION")=$P(NODE,"^",6)
;
;for input interfaces (mapping)
I RTN("ACTION")=1 D Q
.S RTN("AVAIL")=$P(NODE,"^",9)
.Q
;
;for output interfaces
I RTN("ACTION")=2 D Q
.N NODFN
.S NODFN=$P(NODE,"^",15)
.S RTN("NAME")=$P(NODE,"^",1)
.S RTN("RTN")=$P(NODE,"^",2,3)
.S RTN("CHANGES")=$P(NODE,"^",5)
.S RTN("DATATYPE")=$P(NODE,"^",7)
.S RTN("FULL")=$P(NODE,"^",8)
.S RTN("AVAIL")=$P(NODE,"^",9)
.S RTN("ENTRY")=$S(RTN:$G(^IBE(357.6,RTN,4)),1:"")
.S RTN("EXIT")=$S(RTN:$G(^IBE(357.6,RTN,5)),1:"")
.;determine where the interface should put the data
.I NODFN S RTN("DATA_LOCATION")="^TMP(""IB"",$J,""INTERFACES"","""_RTN("NAME")_""")"
.I 'NODFN S RTN("DATA_LOCATION")="^TMP(""IB"",$J,""INTERFACES"",+$G(DFN),"""_RTN("NAME")_""")"
;
;for selection interfaces
I RTN("ACTION")=3 D Q
.S RTN("NAME")=$P(NODE,"^",1)
.S RTN("RTN")=$P(NODE,"^",2,3)
.S RTN("FULL")=$P(NODE,"^",8)
.S RTN("AVAIL")=$P(NODE,"^",9)
.S RTN("DYNAMIC")=$P(NODE,"^",14)
.S RTN("ENTRY")=$S(RTN:$G(^IBE(357.6,RTN,4)),1:"")
.S RTN("EXIT")=$S(RTN:$G(^IBE(357.6,RTN,5)),1:"")
.S RTN("DATA_LOCATION")="^TMP(""IB"",$J,""INTERFACES"","""_RTN("NAME")_""")"
.S RTN("NAME",1)=$$DATANAME(RTN,1),RTN("WIDTH",1)=$$DATANODE(RTN,1)
.S RTN("INPUT_RTN")=$P(NODE,"^",13)
;
;for reports
I RTN("ACTION")=4 D Q
.S RTN("RTN")=$P(NODE,"^",2,3)
.S RTN("AVAIL")=$P(NODE,"^",9)
.S RTN("HSMRY?")=$P(NODE,"^",10)
.S RTN("HSMRY")=$P(NODE,"^",11)
.S RTN("ENTRY")=$S(RTN:$G(^IBE(357.6,RTN,4)),1:"")
.S RTN("EXIT")=$S(RTN:$G(^IBE(357.6,RTN,5)),1:"")
;
;in case the action type is not defined
S RTN("NAME")=$P(NODE,"^",1)
S RTN("RTN")=$P(NODE,"^",2,3)
S RTN("CHANGES")=$P(NODE,"^",5)
S RTN("DATATYPE")=$P(NODE,"^",7)
S RTN("FULL")=$P(NODE,"^",8)
S RTN("AVAIL")=$P(NODE,"^",9)
S RTN("DYNAMIC")=$P(NODE,"^",14)
S RTN("ENTRY")=$S(RTN:$G(^IBE(357.6,RTN,4)),1:"")
S RTN("EXIT")=$S(RTN:$G(^IBE(357.6,RTN,5)),1:"")
;
;I FULL,RTN S IEN=0 F S IEN=$O(^IBE(357.6,RTN,15,IEN)) Q:'IEN S NODE=$G(^IBE(357.6,RTN,15,IEN,0)) D
;.S I=$P(NODE,"^",3)
;.Q:'I
;.S RTN("NODE",I)=$P(NODE,"^",4),RTN("NAME",I)=$P(NODE,"^")
Q
;
WARNING(OBJECT) ; displays a warning
S:'$D(OBJECT) OBJECT="object"
W !,"WARNING! The "_OBJECT_" is partially outside the block."
D PAUSE^IBDFU5
Q
; ** The following routines assume BLKDESCR has been called and the IBBLK array is defined
;
MINX() ;the smallest X a block element can begin at
Q $S((IBBLK("BOX")=1):1,1:0)
;
MAXX() ;the largest X a block element can begin at
Q (IBBLK("W")-(1+$S(IBBLK("BOX")=1:1,1:0)))
;
MINY() ;the smallest Y a block element can begin at
Q $S(IBBLK("BOX")=1:1,1:0)
;
MAXY() ;the largest Y a block element can begin at
Q (IBBLK("H")-(1+$S((IBBLK("BOX")=1):1,1:0)))
;
DORTN(IBRTN,IBDSERCH) ;calls the rtn specified by the pkg interface if ok
;IBRTN is an array containing data from the package interface in format returned by RTNDESCR and MUST be passed by reference
;returns 0 if not successful, 1 otherwise
;IBDSERCH: 1 = Wildcard search for ICD codes
; 2 = Lexicon search for ICD codes.
;Wildcard and Lexicon ICD searches done with the @IBRTN("RTN")
N QUIT,VARIABLE,VARIEN,IBARY
I '$D(IBDSERCH) S IBDSERCH=1 ;Set up Wildcard search as the default search.
S QUIT=0
;
;set IBARY to node where the interface should return the data
I (IBRTN("ACTION")=2)!(IBRTN("ACTION")=3) D
.S IBARY=IBRTN("DATA_LOCATION")
.K @IBARY
;
Q:IBRTN("AVAIL")'=1 0
;
;verify that required variables exist
S VARIEN=0 F S VARIEN=$O(^IBE(357.6,IBRTN,7,VARIEN)) Q:'VARIEN S VARIABLE=$P($G(^IBE(357.6,IBRTN,7,VARIEN,0)),"^") I '$D(@VARIABLE) S QUIT=1 Q
Q:QUIT 0
;
;new protected variables
S VARIEN=0 F S VARIEN=$O(^IBE(357.6,IBRTN,6,VARIEN)) Q:'VARIEN S VARIABLE=$P($G(^IBE(357.6,IBRTN,6,VARIEN,0)),"^") N @VARIABLE
;
;make sure the entry point is known
Q:$G(IBRTN("RTN"))="" 0
;
;make sure the entry point exists
Q:$P(IBRTN("RTN"),"^",2)="" 0
I $P(IBRTN("RTN"),"^")'="" Q:'$L($T(@$P(IBRTN("RTN"),"^")^@$P($P(IBRTN("RTN"),"^",2),"("))) 0
I $P(IBRTN("RTN"),"^")="" Q:'$L($T(^@$P($P(IBRTN("RTN"),"^",2),"("))) 0
;
;call the interface routine,xecute the entry and exit actions
X IBRTN("ENTRY")
D @IBRTN("RTN")
X IBRTN("EXIT")
Q 1
;
DATANAME(RTN,PIECE) ;returns the name of the data for field=piece
Q:'RTN!'PIECE ""
I PIECE=1 Q $P($G(^IBE(357.6,RTN,2)),"^")
N NODE,IEN
S IEN=$O(^IBE(357.6,RTN,15,"C",PIECE,0))
Q:'IEN ""
Q $P($G(^IBE(357.6,RTN,15,IEN,0)),"^")
;
DATANODE(RTN,PIECE) ;returns the node that the field=piece is on
Q:'RTN!'PIECE ""
I PIECE=1 Q ""
S IEN=$O(^IBE(357.6,RTN,15,"C",PIECE,0))
Q:'IEN ""
Q $P($G(^IBE(357.6,RTN,15,IEN,0)),"^",4)
;
DATATYPE(TYPE) ;returns the description of the datatype=TYPE
;TYPE must be passed by reference
;
N NODE
S NODE=""
I $G(TYPE) S NODE=$G(^IBE(359.1,TYPE,0))
S TYPE("SPACE")=$P(NODE,"^",6)
S TYPE("MAX_INPUT")=$P(NODE,"^",2)
S TYPE("FORMAT")=$P(NODE,"^",5)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU1B 5982 printed Sep 02, 2024@19:39:06 Page 2
IBDFU1B ;ALB/CJM - ENCOUNTER FORM ;11/16/92
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
+4 ;utilities
BLKDESCR(IBBLK) ;parses the block record pointed to by IBBLK and puts the
+1 ;description in IBBLK array - should be called by reference
+2 ;returns 1 if block description is too incomplete to print block
+3 if '$GET(IBBLK)
QUIT 1
+4 NEW NODE0
+5 SET NODE0=$GET(^IBE(357.1,IBBLK,0))
+6 SET IBBLK("NAME")=$PIECE(NODE0,"^",1)
+7 SET IBBLK("Y")=$PIECE(NODE0,"^",4)
+8 SET IBBLK("X")=$PIECE(NODE0,"^",5)
+9 SET IBBLK("W")=$PIECE(NODE0,"^",6)
+10 SET IBBLK("H")=$PIECE(NODE0,"^",7)
+11 SET IBBLK("BOX")=$PIECE(NODE0,"^",10)
+12 SET IBBLK("HDR")=$PIECE(NODE0,"^",11)
+13 SET IBBLK("HDISP")=$PIECE(NODE0,"^",12)
+14 SET IBBLK("S")=$PIECE(NODE0,"^",3)
+15 SET IBBLK("PAGE")=1+(IBBLK("Y")\IBFORM("PAGE_HT"))
+16 if NODE0=""
QUIT 1
+17 QUIT 0
+18 ;
RTNDSCR(RTN) ;RTN should be a pointer to the Package Interface file
+1 ;RTN should be passed by reference
+2 ;
+3 NEW NODE
+4 SET NODE=""
SET RTN=+$GET(RTN)
+5 if RTN
SET NODE=$GET(^IBE(357.6,RTN,0))
+6 SET RTN("ACTION")=$PIECE(NODE,"^",6)
+7 ;
+8 ;for input interfaces (mapping)
+9 IF RTN("ACTION")=1
Begin DoDot:1
+10 SET RTN("AVAIL")=$PIECE(NODE,"^",9)
+11 QUIT
End DoDot:1
QUIT
+12 ;
+13 ;for output interfaces
+14 IF RTN("ACTION")=2
Begin DoDot:1
+15 NEW NODFN
+16 SET NODFN=$PIECE(NODE,"^",15)
+17 SET RTN("NAME")=$PIECE(NODE,"^",1)
+18 SET RTN("RTN")=$PIECE(NODE,"^",2,3)
+19 SET RTN("CHANGES")=$PIECE(NODE,"^",5)
+20 SET RTN("DATATYPE")=$PIECE(NODE,"^",7)
+21 SET RTN("FULL")=$PIECE(NODE,"^",8)
+22 SET RTN("AVAIL")=$PIECE(NODE,"^",9)
+23 SET RTN("ENTRY")=$SELECT(RTN:$GET(^IBE(357.6,RTN,4)),1:"")
+24 SET RTN("EXIT")=$SELECT(RTN:$GET(^IBE(357.6,RTN,5)),1:"")
+25 ;determine where the interface should put the data
+26 IF NODFN
SET RTN("DATA_LOCATION")="^TMP(""IB"",$J,""INTERFACES"","""_RTN("NAME")_""")"
+27 IF 'NODFN
SET RTN("DATA_LOCATION")="^TMP(""IB"",$J,""INTERFACES"",+$G(DFN),"""_RTN("NAME")_""")"
End DoDot:1
QUIT
+28 ;
+29 ;for selection interfaces
+30 IF RTN("ACTION")=3
Begin DoDot:1
+31 SET RTN("NAME")=$PIECE(NODE,"^",1)
+32 SET RTN("RTN")=$PIECE(NODE,"^",2,3)
+33 SET RTN("FULL")=$PIECE(NODE,"^",8)
+34 SET RTN("AVAIL")=$PIECE(NODE,"^",9)
+35 SET RTN("DYNAMIC")=$PIECE(NODE,"^",14)
+36 SET RTN("ENTRY")=$SELECT(RTN:$GET(^IBE(357.6,RTN,4)),1:"")
+37 SET RTN("EXIT")=$SELECT(RTN:$GET(^IBE(357.6,RTN,5)),1:"")
+38 SET RTN("DATA_LOCATION")="^TMP(""IB"",$J,""INTERFACES"","""_RTN("NAME")_""")"
+39 SET RTN("NAME",1)=$$DATANAME(RTN,1)
SET RTN("WIDTH",1)=$$DATANODE(RTN,1)
+40 SET RTN("INPUT_RTN")=$PIECE(NODE,"^",13)
End DoDot:1
QUIT
+41 ;
+42 ;for reports
+43 IF RTN("ACTION")=4
Begin DoDot:1
+44 SET RTN("RTN")=$PIECE(NODE,"^",2,3)
+45 SET RTN("AVAIL")=$PIECE(NODE,"^",9)
+46 SET RTN("HSMRY?")=$PIECE(NODE,"^",10)
+47 SET RTN("HSMRY")=$PIECE(NODE,"^",11)
+48 SET RTN("ENTRY")=$SELECT(RTN:$GET(^IBE(357.6,RTN,4)),1:"")
+49 SET RTN("EXIT")=$SELECT(RTN:$GET(^IBE(357.6,RTN,5)),1:"")
End DoDot:1
QUIT
+50 ;
+51 ;in case the action type is not defined
+52 SET RTN("NAME")=$PIECE(NODE,"^",1)
+53 SET RTN("RTN")=$PIECE(NODE,"^",2,3)
+54 SET RTN("CHANGES")=$PIECE(NODE,"^",5)
+55 SET RTN("DATATYPE")=$PIECE(NODE,"^",7)
+56 SET RTN("FULL")=$PIECE(NODE,"^",8)
+57 SET RTN("AVAIL")=$PIECE(NODE,"^",9)
+58 SET RTN("DYNAMIC")=$PIECE(NODE,"^",14)
+59 SET RTN("ENTRY")=$SELECT(RTN:$GET(^IBE(357.6,RTN,4)),1:"")
+60 SET RTN("EXIT")=$SELECT(RTN:$GET(^IBE(357.6,RTN,5)),1:"")
+61 ;
+62 ;I FULL,RTN S IEN=0 F S IEN=$O(^IBE(357.6,RTN,15,IEN)) Q:'IEN S NODE=$G(^IBE(357.6,RTN,15,IEN,0)) D
+63 ;.S I=$P(NODE,"^",3)
+64 ;.Q:'I
+65 ;.S RTN("NODE",I)=$P(NODE,"^",4),RTN("NAME",I)=$P(NODE,"^")
+66 QUIT
+67 ;
WARNING(OBJECT) ; displays a warning
+1 if '$DATA(OBJECT)
SET OBJECT="object"
+2 WRITE !,"WARNING! The "_OBJECT_" is partially outside the block."
+3 DO PAUSE^IBDFU5
+4 QUIT
+5 ; ** The following routines assume BLKDESCR has been called and the IBBLK array is defined
+6 ;
MINX() ;the smallest X a block element can begin at
+1 QUIT $SELECT((IBBLK("BOX")=1):1,1:0)
+2 ;
MAXX() ;the largest X a block element can begin at
+1 QUIT (IBBLK("W")-(1+$SELECT(IBBLK("BOX")=1:1,1:0)))
+2 ;
MINY() ;the smallest Y a block element can begin at
+1 QUIT $SELECT(IBBLK("BOX")=1:1,1:0)
+2 ;
MAXY() ;the largest Y a block element can begin at
+1 QUIT (IBBLK("H")-(1+$SELECT((IBBLK("BOX")=1):1,1:0)))
+2 ;
DORTN(IBRTN,IBDSERCH) ;calls the rtn specified by the pkg interface if ok
+1 ;IBRTN is an array containing data from the package interface in format returned by RTNDESCR and MUST be passed by reference
+2 ;returns 0 if not successful, 1 otherwise
+3 ;IBDSERCH: 1 = Wildcard search for ICD codes
+4 ; 2 = Lexicon search for ICD codes.
+5 ;Wildcard and Lexicon ICD searches done with the @IBRTN("RTN")
+6 NEW QUIT,VARIABLE,VARIEN,IBARY
+7 ;Set up Wildcard search as the default search.
IF '$DATA(IBDSERCH)
SET IBDSERCH=1
+8 SET QUIT=0
+9 ;
+10 ;set IBARY to node where the interface should return the data
+11 IF (IBRTN("ACTION")=2)!(IBRTN("ACTION")=3)
Begin DoDot:1
+12 SET IBARY=IBRTN("DATA_LOCATION")
+13 KILL @IBARY
End DoDot:1
+14 ;
+15 if IBRTN("AVAIL")'=1
QUIT 0
+16 ;
+17 ;verify that required variables exist
+18 SET VARIEN=0
FOR
SET VARIEN=$ORDER(^IBE(357.6,IBRTN,7,VARIEN))
if 'VARIEN
QUIT
SET VARIABLE=$PIECE($GET(^IBE(357.6,IBRTN,7,VARIEN,0)),"^")
IF '$DATA(@VARIABLE)
SET QUIT=1
QUIT
+19 if QUIT
QUIT 0
+20 ;
+21 ;new protected variables
+22 SET VARIEN=0
FOR
SET VARIEN=$ORDER(^IBE(357.6,IBRTN,6,VARIEN))
if 'VARIEN
QUIT
SET VARIABLE=$PIECE($GET(^IBE(357.6,IBRTN,6,VARIEN,0)),"^")
NEW @VARIABLE
+23 ;
+24 ;make sure the entry point is known
+25 if $GET(IBRTN("RTN"))=""
QUIT 0
+26 ;
+27 ;make sure the entry point exists
+28 if $PIECE(IBRTN("RTN"),"^",2)=""
QUIT 0
+29 IF $PIECE(IBRTN("RTN"),"^")'=""
if '$LENGTH($TEXT(@$PIECE(IBRTN("RTN"),"^")^@$PIECE($PIECE(IBRTN("RTN"),"^",2),"(")))
QUIT 0
+30 IF $PIECE(IBRTN("RTN"),"^")=""
if '$LENGTH($TEXT(^@$PIECE($PIECE(IBRTN("RTN"),"^",2),"(")))
QUIT 0
+31 ;
+32 ;call the interface routine,xecute the entry and exit actions
+33 XECUTE IBRTN("ENTRY")
+34 DO @IBRTN("RTN")
+35 XECUTE IBRTN("EXIT")
+36 QUIT 1
+37 ;
DATANAME(RTN,PIECE) ;returns the name of the data for field=piece
+1 if 'RTN!'PIECE
QUIT ""
+2 IF PIECE=1
QUIT $PIECE($GET(^IBE(357.6,RTN,2)),"^")
+3 NEW NODE,IEN
+4 SET IEN=$ORDER(^IBE(357.6,RTN,15,"C",PIECE,0))
+5 if 'IEN
QUIT ""
+6 QUIT $PIECE($GET(^IBE(357.6,RTN,15,IEN,0)),"^")
+7 ;
DATANODE(RTN,PIECE) ;returns the node that the field=piece is on
+1 if 'RTN!'PIECE
QUIT ""
+2 IF PIECE=1
QUIT ""
+3 SET IEN=$ORDER(^IBE(357.6,RTN,15,"C",PIECE,0))
+4 if 'IEN
QUIT ""
+5 QUIT $PIECE($GET(^IBE(357.6,RTN,15,IEN,0)),"^",4)
+6 ;
DATATYPE(TYPE) ;returns the description of the datatype=TYPE
+1 ;TYPE must be passed by reference
+2 ;
+3 NEW NODE
+4 SET NODE=""
+5 IF $GET(TYPE)
SET NODE=$GET(^IBE(359.1,TYPE,0))
+6 SET TYPE("SPACE")=$PIECE(NODE,"^",6)
+7 SET TYPE("MAX_INPUT")=$PIECE(NODE,"^",2)
+8 SET TYPE("FORMAT")=$PIECE(NODE,"^",5)
+9 QUIT
