- 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 ;
