- 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 Jan 18, 2025@03:54:43 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