INHPSA ; FRW ; 10 Jun 99 14:45; Interface Control Program - Main Application Interface
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
Q
;
PROCINT(INTER,INPAR,INNAME,INDATA,INMESS) ;Process one interface
;This is called as the control routine for most interfaces
;Called from PROC^INHPSAM
;INPUT:
; INTER - interface application identifier
; INPAR - array of parameters
; INNAME - name of application
; INDATA - executable MUMPS code to get data array
; should leave data in the array INDAT
; INMESS - executable code to be done after the load is complete
;
N HDR,INMTF,INTIME
S INNAME=$G(INNAME),INTER=$G(INTER),INDATA=$G(INDATA),INMESS=$G(INMESS)
Q:'$L(INTER) 0
N INERR,INDAT
S INERR=""
;Get default name
S:'$L(INNAME) INNAME=$P($G(INPAR("APPL",INTER)),U)
;
S INMTF=$$GETMTF(),INTIME=$$CDATASC^%ZTFDT($H,1,1)
S HDR(1)="INMTF,?(IOM-27),INTIME,"" PAGE:"",$J(INPAGE,4)"
S HDR(2)="""Interface Name: "_INNAME_""""
S HDR(3)="",$P(HDR(3),"-",IOM)="",HDR(3)=""""_HDR(3)_""",!"
D HEADER^INHMG
;
;Create array of data for application
K INDAT
;Check for custom defined data builder code
I $L(INDATA) X INDATA I INERR D T^INHMG1 W "ERROR: ",INNAME," - no action taken" S INERR=1 Q 0
;Execute standard data builder
I '$L(INDATA) I '$$CREDAT(.INDAT) D T^INHMG1 W "ERROR: Unable to create data array." S INERR=1 Q 0
;Process application
D ONE(INTER,.INDAT,.INPAR) Q:$G(DUOUT) $S('INERR:1,1:0)
;post-processing logic
D:INPAR("ACT")'=2 POST^INHPSA2(INTER,INMESS)
I INPAR("ACT")=2,$G(INDISCRP) D DISCREP^INHPSA4(ININT,.INDAT)
;Quit positive if no errors, null if errors encoutnered
Q $S('INERR:1,1:0)
;
ONE(INTER,INDAT,INPAR) ;Activate/Deactivate one interface
;INPUT:
; INTER - interface application to activate
; INDAT - data array of control file records for application (PBR)
; INPAR - array of parameters (pass by ref)
;
;Background Process(es)
D BACK(INTER,.INDAT,.INPAR)
;Transaction Type(s)
D TT(INTER,.INDAT,.INPAR) Q:$G(DUOOUT)
;Script Generator Messages
D MSG(INTER,.INDAT,.INPAR)
;
Q
;
MSG(INTER,INDAT,INPAR) ;Script Generator Messages
;
;Not currently supported - assumes all messages will be active
Q
;
MSGONE(DA,INST) ;Activate/Deactivate one message //??? where is this called from
;
S INST=+$G(INST) N DIE,DR,INSTMSG
S INSTMSG=$S('INST:"DEACTIVATED",1:"ACTIVATED")
;Set INACTIVE flag
S DIE=4011,DR=".08///"_$S('INST:1,1:0) D ^DIE
W:'$G(INVERBOS) !,"Script Generator Message: ",$P(^INTHL7M(DA,0),U)," ",INSTMSG
Q
;
;?? Compile Message
;?? Should transaction types for messages also be deactivated
;?? Should scripts for message also be deactivated
;?? Should anything be done with the Message Replication File - DEFER
Q
;
BACK(INTER,INDAT,INPAR) ;Background Process(es)
;
;Activate background process
N INREC S INREC=0
F S INREC=$O(INDAT(INTER,4004,INREC)) Q:'INREC S:'$$BPCONE(INREC,+$G(INPAR("ACT"))) INERR=1
;
Q
;
BPCONE(DA,INST) ;Activate/Deactivate one background process
;INPUT:
; DA - entry to process in INDAT
; INST - what to do 0 - deactivate (def) ; 1 - activate, 2 - show
;
N DIC,X,Y,DIE,DR,INSTMSG,INNAME
S INST=+$G(INST)
S (INNAME,X)=$P($G(INDAT(INTER,4004,DA)),U,1),DIC=4004,DIC(0)="",Y=$$DIC(DIC,X,"",DIC(0)),DA=+Y
I INNAME'=$P(Y,U,2) D T^INHMG1 W "ERROR: Wanted background process ",INNAME," but found ",$P(Y,U,2)," (",+Y,")." Q 0
I DA<0 D T^INHMG1 W "ERROR: Background Process: ",INNAME," not found." Q 0
I INST=2 D Q 1
.S INSTMSG=$S('$P($G(^INTHPC(DA,0)),U,2):"INACTIVE",1:"ACTIVE")
.D T^INHMG1 W "Background Process: ",$P(^INTHPC(DA,0),U),?68,INSTMSG
;
S INSTMSG=$S('INST:"DEACTIVATED",1:"ACTIVATED")
S DIE=4004,DR=".02///"_INST
;If activated, then check debug level
I INST,+$P($G(^INTHPC(DA,9)),U,1)'=0 D
.D T^INHMG1 W "Debug will be turned off for Background Process: ",INNAME
.S DR=DR_";"_9.01_"///0"
D ^DIE
I +$P($G(^INTHPC(DA,9)),U,1)'=0 D T^INHMG1 W "Warning: Background Process: ",INNAME," debug is still ON"
I $P($G(^INTHPC(DA,0)),U,2)'=INST D T^INHMG1 W "ERROR: Background Process: ",INNAME," not ",INSTMSG S INERR=1 Q 0
I '$G(INVERBOS) D T^INHMG1 W "Background Process: ",$P(^INTHPC(DA,0),U),?68,INSTMSG
Q 1
;
;Need to handle other data nodes for record if present
;
TT(INTER,INDAT,INPAR) ;Transaction Types
;
;De/Activate Transaction Type
N INREC S INREC=0
F S INREC=$O(INDAT(INTER,4000,INREC)) Q:'INREC S:'$$TTONE(INREC,+$G(INPAR("ACT"))) INERR=1 Q:$G(DUOUT)
;
Q
;
TTONE(DA,INST) ;Deactivate/activate one transaction type
;
N DIC,X,Y,DIE,DR,INSTMSG,INNAME
N INHIER ;this array is used to show the transaction hierarchy
S INHIER("PARENT")=""
S INHIER("CHILD")=""
S INHIER("BASE")=""
;
S INST=+$G(INST)
;Quit if deactivating and suppress deactivation flag is set
Q:'INST&$P($G(INDAT(INTER,4000,DA)),U,2) 1
;Quit if activating and suppress activation flag is set
Q:INST&$P($G(INDAT(INTER,4000,DA)),U,3) 1
S (INNAME,X)=$P($G(INDAT(INTER,4000,DA)),U,1),DIC=4000,DIC(0)="",Y=$$DIC(DIC,X,"",DIC(0)),DA=+Y
I INNAME'=$P(Y,U,2) D T^INHMG1 W "ERROR: Wanted transaction type ",INNAME," but found ",$P(Y,U,2)," (",+Y,")." Q 0
I DA<0 D T^INHMG1 W "ERROR: Transaction Type: ",INNAME," not found." Q 0
Q:'$$TTEDT(DA,INST,.INHIER,"CHILD") 0
;
;Process Base (if DA is Replicant TT)
Q:'$$TTBASE^INHPSA4(DA,INST,.INHIER) 0
;
;Process Parent
Q:'$$TTPAR(DA,INST,.INHIER) 0
D WRITE^INHPSA4(.INHIER,INST)
;
Q 1
;
TTPAR(DA,INST,INHIER) ;Process parent transaction types
;DA - ien of child transaction type
;
N INCHTT,INPATT,OK,INCUST,TT
Q:'$D(^INRHT(+$G(DA),0)) 0
S INCHTT=+DA,INPATT=+$P(^INRHT(DA,0),U,6)
;If no parent quit with no error
Q:'INPATT 1
;If parent doesn't exist quit with error
I '$D(^INRHT(INPATT,0)) D T^INHMG1 W "ERROR: Parent transaction type deleted for ",$P($G(^INRHT(+DA,0)),U,1)," ",INPATT Q 0
;
;Get current status of parent
S INCUST=$P(^INRHT(INPATT,0),U,5)
;
;Perform activation process
I INST=1 D:'INCUST
. ;Parent is NOT active - check for active children
. S TT="" F S TT=$O(^INRHT("AC",INPATT,TT)) Q:'TT D
.. ;no warning if TT is calling child or is inactive
.. Q:(TT=DA)!('$P($G(^INRHT(TT,0)),U,5))
.. D T^INHMG1 W "WARNING: Transaction type ",$P(^INRHT(TT,0),U)," was active. "
.. D T^INHMG1 W " Messages will now be generated for this transaction type."
;
;Perform deactivation process
I 'INST S OK=1 D:INCUST Q:'OK 1 ; exit if NOT OK to deactivate parent
. ;Parent is active - check for active children
. ;no deactivation if TT is NOT the calling child & is active
. S TT="" F S TT=$O(^INRHT("AC",INPATT,TT)) Q:'TT I TT'=DA,$P($G(^INRHT(TT,0)),U,5) S OK=0 Q
;
; De/Activate parent TT
Q:'$$TTEDT(INPATT,INST,.INHIER,"PARENT") 0
;
Q 1
;
TTEDT(DA,INST,INHIER,INODE) ;Edit transaction type
;
S:INST'=2 INSTMSG=$S('INST:"DEACTIVATED",1:"ACTIVATED")
I INST'=2 S DIE=4000,DR=".05///"_INST D ^DIE
I INST'=2,$P($G(^INRHT(DA,0)),U,5)'=INST D T^INHMG1 W "ERROR: Transaction Type: ",INNAME," not ",INSTMSG Q 0
S:INST=2 INSTMSG=$S($P($G(^INRHT(DA,0)),U,5)=1:"ACTIVE",1:"INACTIVE")
S INHIER(INODE)=DA
Q 1
;
;Should anything be done with the Message Replication File - DEFER
;Should script be recompiled if activating - probably
;
CREDAT(INDAT) ;Create data array of control records
;
N INERR,L1,TXT S INERR=1
;Load data into array
F LI=1:1 S TXT=$P($$TEXT^INHPSA1(INTER,LI),";;",2,99) Q:'TXT I '$$LOAD(.INDAT,TXT,INTER) S INERR=0
Q INERR
;
LOAD(INDAT,TXT,INTER) ;Load a node of data into data array
;INPUT:
; INDAT - data array of control file records for application (PBR)
; TXT - line of data to load into array (from INHPSA1)
; foramt -> file # ^ node ^ data
; INTER - interface application
;
N INREC
;Check for comment line
Q:$E(TXT,1)[";" 1
;Error if no file has been defined
Q:'TXT 0
;Set record counter to last record used for file
S INREC=$G(INDAT(INTER,+TXT))
;Check for new record (2nd piece = null)
I '$L($P(TXT,U,2)) D Q 1
. ;Increment record counter
. S INREC=INREC+1,INDAT(INTER,+TXT)=INREC
. ;Used for the lookup value to DIC call
. S INDAT(INTER,+TXT,INREC)=$P(TXT,U,3,99)
;Capture any data nodes
S INDAT(INTER,+TXT,INREC,+$P(TXT,U,2))=$P(TXT,U,3,99)
Q 1
;
DIC(DIC,X,DLAYGO,%IPS,DOA,%L,DINUM) ;dic lookup
;
; 10/17/95 Matches lookup in DIC^INHSYS05 (which may not be present
; during GIS s/w installation).
;
;input:
; DIC - Global Root: Can be a string or file number
; If a file number, this function returns -1
; when looking at a multiple
; X - Stuff this bud
; DLAYGO - file number and formatting
; %IPS - input parameter string; see DIC(0) documentation
; DOA - array of previous DA values; passed by referrence
; %L - current level
; DINUM (opt) - force this ien
;output:
; Y - What DIC returns
N G,DA,I,Y
I DIC Q:DIC'>0!($G(DOA)&$G(%L)) -1 S DIC=$G(^DIC(DIC,0,"GL")) Q:DIC="" -1
I $G(DOA),($G(%L)) D
.F I=%L:-1:2 S DA(I)=DOA(I-1)
.S DA(1)=DOA
S G=DIC_"0)" S:'$D(@G) @G="^"_DLAYGO_"^^"
;Ugly cross ref lookup since ^DIC chokes on >30 Xact match lookups
I $L(X)>30 S Y=$O(@(DIC_"""B"","""_X_""","""")")) Q $S(Y:Y_U_$P(@(DIC_Y_",0)"),U),1:-1)
S DIC(0)=%IPS
I '$D(DINUM) D ^DIC
I $D(DINUM) D ^DICN
Q Y
;
GETMTF() ;Get the name of the primary MTF (only one per CHCS system)
N Y,X
S Y=$G(^DD("SITE",1)) Q:'Y ""
S X=$P($G(^DIC(4,Y,0)),U)
Q X
;
INHPSA ; FRW ; 10 Jun 99 14:45; Interface Control Program - Main Application Interface
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 QUIT
+5 ;
PROCINT(INTER,INPAR,INNAME,INDATA,INMESS) ;Process one interface
+1 ;This is called as the control routine for most interfaces
+2 ;Called from PROC^INHPSAM
+3 ;INPUT:
+4 ; INTER - interface application identifier
+5 ; INPAR - array of parameters
+6 ; INNAME - name of application
+7 ; INDATA - executable MUMPS code to get data array
+8 ; should leave data in the array INDAT
+9 ; INMESS - executable code to be done after the load is complete
+10 ;
+11 NEW HDR,INMTF,INTIME
+12 SET INNAME=$GET(INNAME)
SET INTER=$GET(INTER)
SET INDATA=$GET(INDATA)
SET INMESS=$GET(INMESS)
+13 IF '$LENGTH(INTER)
QUIT 0
+14 NEW INERR,INDAT
+15 SET INERR=""
+16 ;Get default name
+17 IF '$LENGTH(INNAME)
SET INNAME=$PIECE($GET(INPAR("APPL",INTER)),U)
+18 ;
+19 SET INMTF=$$GETMTF()
SET INTIME=$$CDATASC^%ZTFDT($HOROLOG,1,1)
+20 SET HDR(1)="INMTF,?(IOM-27),INTIME,"" PAGE:"",$J(INPAGE,4)"
+21 SET HDR(2)="""Interface Name: "_INNAME_""""
+22 SET HDR(3)=""
SET $PIECE(HDR(3),"-",IOM)=""
SET HDR(3)=""""_HDR(3)_""",!"
+23 DO HEADER^INHMG
+24 ;
+25 ;Create array of data for application
+26 KILL INDAT
+27 ;Check for custom defined data builder code
+28 IF $LENGTH(INDATA)
XECUTE INDATA
IF INERR
DO T^INHMG1
WRITE "ERROR: ",INNAME," - no action taken"
SET INERR=1
QUIT 0
+29 ;Execute standard data builder
+30 IF '$LENGTH(INDATA)
IF '$$CREDAT(.INDAT)
DO T^INHMG1
WRITE "ERROR: Unable to create data array."
SET INERR=1
QUIT 0
+31 ;Process application
+32 DO ONE(INTER,.INDAT,.INPAR)
IF $GET(DUOUT)
QUIT $SELECT('INERR:1,1:0)
+33 ;post-processing logic
+34 IF INPAR("ACT")'=2
DO POST^INHPSA2(INTER,INMESS)
+35 IF INPAR("ACT")=2
IF $GET(INDISCRP)
DO DISCREP^INHPSA4(ININT,.INDAT)
+36 ;Quit positive if no errors, null if errors encoutnered
+37 QUIT $SELECT('INERR:1,1:0)
+38 ;
ONE(INTER,INDAT,INPAR) ;Activate/Deactivate one interface
+1 ;INPUT:
+2 ; INTER - interface application to activate
+3 ; INDAT - data array of control file records for application (PBR)
+4 ; INPAR - array of parameters (pass by ref)
+5 ;
+6 ;Background Process(es)
+7 DO BACK(INTER,.INDAT,.INPAR)
+8 ;Transaction Type(s)
+9 DO TT(INTER,.INDAT,.INPAR)
IF $GET(DUOOUT)
QUIT
+10 ;Script Generator Messages
+11 DO MSG(INTER,.INDAT,.INPAR)
+12 ;
+13 QUIT
+14 ;
MSG(INTER,INDAT,INPAR) ;Script Generator Messages
+1 ;
+2 ;Not currently supported - assumes all messages will be active
+3 QUIT
+4 ;
MSGONE(DA,INST) ;Activate/Deactivate one message //??? where is this called from
+1 ;
+2 SET INST=+$GET(INST)
NEW DIE,DR,INSTMSG
+3 SET INSTMSG=$SELECT('INST:"DEACTIVATED",1:"ACTIVATED")
+4 ;Set INACTIVE flag
+5 SET DIE=4011
SET DR=".08///"_$SELECT('INST:1,1:0)
DO ^DIE
+6 IF '$GET(INVERBOS)
WRITE !,"Script Generator Message: ",$PIECE(^INTHL7M(DA,0),U)," ",INSTMSG
+7 QUIT
+8 ;
+9 ;?? Compile Message
+10 ;?? Should transaction types for messages also be deactivated
+11 ;?? Should scripts for message also be deactivated
+12 ;?? Should anything be done with the Message Replication File - DEFER
+13 QUIT
+14 ;
BACK(INTER,INDAT,INPAR) ;Background Process(es)
+1 ;
+2 ;Activate background process
+3 NEW INREC
SET INREC=0
+4 FOR
SET INREC=$ORDER(INDAT(INTER,4004,INREC))
IF 'INREC
QUIT
IF '$$BPCONE(INREC,+$GET(INPAR("ACT")))
SET INERR=1
+5 ;
+6 QUIT
+7 ;
BPCONE(DA,INST) ;Activate/Deactivate one background process
+1 ;INPUT:
+2 ; DA - entry to process in INDAT
+3 ; INST - what to do 0 - deactivate (def) ; 1 - activate, 2 - show
+4 ;
+5 NEW DIC,X,Y,DIE,DR,INSTMSG,INNAME
+6 SET INST=+$GET(INST)
+7 SET (INNAME,X)=$PIECE($GET(INDAT(INTER,4004,DA)),U,1)
SET DIC=4004
SET DIC(0)=""
SET Y=$$DIC(DIC,X,"",DIC(0))
SET DA=+Y
+8 IF INNAME'=$PIECE(Y,U,2)
DO T^INHMG1
WRITE "ERROR: Wanted background process ",INNAME," but found ",$PIECE(Y,U,2)," (",+Y,")."
QUIT 0
+9 IF DA<0
DO T^INHMG1
WRITE "ERROR: Background Process: ",INNAME," not found."
QUIT 0
+10 IF INST=2
Begin DoDot:1
+11 SET INSTMSG=$SELECT('$PIECE($GET(^INTHPC(DA,0)),U,2):"INACTIVE",1:"ACTIVE")
+12 DO T^INHMG1
WRITE "Background Process: ",$PIECE(^INTHPC(DA,0),U),?68,INSTMSG
End DoDot:1
QUIT 1
+13 ;
+14 SET INSTMSG=$SELECT('INST:"DEACTIVATED",1:"ACTIVATED")
+15 SET DIE=4004
SET DR=".02///"_INST
+16 ;If activated, then check debug level
+17 IF INST
IF +$PIECE($GET(^INTHPC(DA,9)),U,1)'=0
Begin DoDot:1
+18 DO T^INHMG1
WRITE "Debug will be turned off for Background Process: ",INNAME
+19 SET DR=DR_";"_9.01_"///0"
End DoDot:1
+20 DO ^DIE
+21 IF +$PIECE($GET(^INTHPC(DA,9)),U,1)'=0
DO T^INHMG1
WRITE "Warning: Background Process: ",INNAME," debug is still ON"
+22 IF $PIECE($GET(^INTHPC(DA,0)),U,2)'=INST
DO T^INHMG1
WRITE "ERROR: Background Process: ",INNAME," not ",INSTMSG
SET INERR=1
QUIT 0
+23 IF '$GET(INVERBOS)
DO T^INHMG1
WRITE "Background Process: ",$PIECE(^INTHPC(DA,0),U),?68,INSTMSG
+24 QUIT 1
+25 ;
+26 ;Need to handle other data nodes for record if present
+27 ;
TT(INTER,INDAT,INPAR) ;Transaction Types
+1 ;
+2 ;De/Activate Transaction Type
+3 NEW INREC
SET INREC=0
+4 FOR
SET INREC=$ORDER(INDAT(INTER,4000,INREC))
IF 'INREC
QUIT
IF '$$TTONE(INREC,+$GET(INPAR("ACT")))
SET INERR=1
IF $GET(DUOUT)
QUIT
+5 ;
+6 QUIT
+7 ;
TTONE(DA,INST) ;Deactivate/activate one transaction type
+1 ;
+2 NEW DIC,X,Y,DIE,DR,INSTMSG,INNAME
+3 ;this array is used to show the transaction hierarchy
NEW INHIER
+4 SET INHIER("PARENT")=""
+5 SET INHIER("CHILD")=""
+6 SET INHIER("BASE")=""
+7 ;
+8 SET INST=+$GET(INST)
+9 ;Quit if deactivating and suppress deactivation flag is set
+10 IF 'INST&$PIECE($GET(INDAT(INTER,4000,DA)),U,2)
QUIT 1
+11 ;Quit if activating and suppress activation flag is set
+12 IF INST&$PIECE($GET(INDAT(INTER,4000,DA)),U,3)
QUIT 1
+13 SET (INNAME,X)=$PIECE($GET(INDAT(INTER,4000,DA)),U,1)
SET DIC=4000
SET DIC(0)=""
SET Y=$$DIC(DIC,X,"",DIC(0))
SET DA=+Y
+14 IF INNAME'=$PIECE(Y,U,2)
DO T^INHMG1
WRITE "ERROR: Wanted transaction type ",INNAME," but found ",$PIECE(Y,U,2)," (",+Y,")."
QUIT 0
+15 IF DA<0
DO T^INHMG1
WRITE "ERROR: Transaction Type: ",INNAME," not found."
QUIT 0
+16 IF '$$TTEDT(DA,INST,.INHIER,"CHILD")
QUIT 0
+17 ;
+18 ;Process Base (if DA is Replicant TT)
+19 IF '$$TTBASE^INHPSA4(DA,INST,.INHIER)
QUIT 0
+20 ;
+21 ;Process Parent
+22 IF '$$TTPAR(DA,INST,.INHIER)
QUIT 0
+23 DO WRITE^INHPSA4(.INHIER,INST)
+24 ;
+25 QUIT 1
+26 ;
TTPAR(DA,INST,INHIER) ;Process parent transaction types
+1 ;DA - ien of child transaction type
+2 ;
+3 NEW INCHTT,INPATT,OK,INCUST,TT
+4 IF '$DATA(^INRHT(+$GET(DA),0))
QUIT 0
+5 SET INCHTT=+DA
SET INPATT=+$PIECE(^INRHT(DA,0),U,6)
+6 ;If no parent quit with no error
+7 IF 'INPATT
QUIT 1
+8 ;If parent doesn't exist quit with error
+9 IF '$DATA(^INRHT(INPATT,0))
DO T^INHMG1
WRITE "ERROR: Parent transaction type deleted for ",$PIECE($GET(^INRHT(+DA,0)),U,1)," ",INPATT
QUIT 0
+10 ;
+11 ;Get current status of parent
+12 SET INCUST=$PIECE(^INRHT(INPATT,0),U,5)
+13 ;
+14 ;Perform activation process
+15 IF INST=1
IF 'INCUST
Begin DoDot:1
+16 ;Parent is NOT active - check for active children
+17 SET TT=""
FOR
SET TT=$ORDER(^INRHT("AC",INPATT,TT))
IF 'TT
QUIT
Begin DoDot:2
+18 ;no warning if TT is calling child or is inactive
+19 IF (TT=DA)!('$PIECE($GET(^INRHT(TT,0)),U,5))
QUIT
+20 DO T^INHMG1
WRITE "WARNING: Transaction type ",$PIECE(^INRHT(TT,0),U)," was active. "
+21 DO T^INHMG1
WRITE " Messages will now be generated for this transaction type."
End DoDot:2
End DoDot:1
+22 ;
+23 ;Perform deactivation process
+24 ; exit if NOT OK to deactivate parent
IF 'INST
SET OK=1
IF INCUST
Begin DoDot:1
+25 ;Parent is active - check for active children
+26 ;no deactivation if TT is NOT the calling child & is active
+27 SET TT=""
FOR
SET TT=$ORDER(^INRHT("AC",INPATT,TT))
IF 'TT
QUIT
IF TT'=DA
IF $PIECE($GET(^INRHT(TT,0)),U,5)
SET OK=0
QUIT
End DoDot:1
IF 'OK
QUIT 1
+28 ;
+29 ; De/Activate parent TT
+30 IF '$$TTEDT(INPATT,INST,.INHIER,"PARENT")
QUIT 0
+31 ;
+32 QUIT 1
+33 ;
TTEDT(DA,INST,INHIER,INODE) ;Edit transaction type
+1 ;
+2 IF INST'=2
SET INSTMSG=$SELECT('INST:"DEACTIVATED",1:"ACTIVATED")
+3 IF INST'=2
SET DIE=4000
SET DR=".05///"_INST
DO ^DIE
+4 IF INST'=2
IF $PIECE($GET(^INRHT(DA,0)),U,5)'=INST
DO T^INHMG1
WRITE "ERROR: Transaction Type: ",INNAME," not ",INSTMSG
QUIT 0
+5 IF INST=2
SET INSTMSG=$SELECT($PIECE($GET(^INRHT(DA,0)),U,5)=1:"ACTIVE",1:"INACTIVE")
+6 SET INHIER(INODE)=DA
+7 QUIT 1
+8 ;
+9 ;Should anything be done with the Message Replication File - DEFER
+10 ;Should script be recompiled if activating - probably
+11 ;
CREDAT(INDAT) ;Create data array of control records
+1 ;
+2 NEW INERR,L1,TXT
SET INERR=1
+3 ;Load data into array
+4 FOR LI=1:1
SET TXT=$PIECE($$TEXT^INHPSA1(INTER,LI),";;",2,99)
IF 'TXT
QUIT
IF '$$LOAD(.INDAT,TXT,INTER)
SET INERR=0
+5 QUIT INERR
+6 ;
LOAD(INDAT,TXT,INTER) ;Load a node of data into data array
+1 ;INPUT:
+2 ; INDAT - data array of control file records for application (PBR)
+3 ; TXT - line of data to load into array (from INHPSA1)
+4 ; foramt -> file # ^ node ^ data
+5 ; INTER - interface application
+6 ;
+7 NEW INREC
+8 ;Check for comment line
+9 IF $EXTRACT(TXT,1)[";"
QUIT 1
+10 ;Error if no file has been defined
+11 IF 'TXT
QUIT 0
+12 ;Set record counter to last record used for file
+13 SET INREC=$GET(INDAT(INTER,+TXT))
+14 ;Check for new record (2nd piece = null)
+15 IF '$LENGTH($PIECE(TXT,U,2))
Begin DoDot:1
+16 ;Increment record counter
+17 SET INREC=INREC+1
SET INDAT(INTER,+TXT)=INREC
+18 ;Used for the lookup value to DIC call
+19 SET INDAT(INTER,+TXT,INREC)=$PIECE(TXT,U,3,99)
End DoDot:1
QUIT 1
+20 ;Capture any data nodes
+21 SET INDAT(INTER,+TXT,INREC,+$PIECE(TXT,U,2))=$PIECE(TXT,U,3,99)
+22 QUIT 1
+23 ;
DIC(DIC,X,DLAYGO,%IPS,DOA,%L,DINUM) ;dic lookup
+1 ;
+2 ; 10/17/95 Matches lookup in DIC^INHSYS05 (which may not be present
+3 ; during GIS s/w installation).
+4 ;
+5 ;input:
+6 ; DIC - Global Root: Can be a string or file number
+7 ; If a file number, this function returns -1
+8 ; when looking at a multiple
+9 ; X - Stuff this bud
+10 ; DLAYGO - file number and formatting
+11 ; %IPS - input parameter string; see DIC(0) documentation
+12 ; DOA - array of previous DA values; passed by referrence
+13 ; %L - current level
+14 ; DINUM (opt) - force this ien
+15 ;output:
+16 ; Y - What DIC returns
+17 NEW G,DA,I,Y
+18 IF DIC
IF DIC'>0!($GET(DOA)&$GET(%L))
QUIT -1
SET DIC=$GET(^DIC(DIC,0,"GL"))
IF DIC=""
QUIT -1
+19 IF $GET(DOA)
IF ($GET(%L))
Begin DoDot:1
+20 FOR I=%L:-1:2
SET DA(I)=DOA(I-1)
+21 SET DA(1)=DOA
End DoDot:1
+22 SET G=DIC_"0)"
IF '$DATA(@G)
SET @G="^"_DLAYGO_"^^"
+23 ;Ugly cross ref lookup since ^DIC chokes on >30 Xact match lookups
+24 IF $LENGTH(X)>30
SET Y=$ORDER(@(DIC_"""B"","""_X_""","""")"))
QUIT $SELECT(Y:Y_U_$PIECE(@(DIC_Y_",0)"),U),1:-1)
+25 SET DIC(0)=%IPS
+26 IF '$DATA(DINUM)
DO ^DIC
+27 IF $DATA(DINUM)
DO ^DICN
+28 QUIT Y
+29 ;
GETMTF() ;Get the name of the primary MTF (only one per CHCS system)
+1 NEW Y,X
+2 SET Y=$GET(^DD("SITE",1))
IF 'Y
QUIT ""
+3 SET X=$PIECE($GET(^DIC(4,Y,0)),U)
+4 QUIT X
+5 ;
